home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2 - Developers' Solutions / Delphi 2 Developers' Solutions.iso / dds / chap03 / howto08 / drwsutl3.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-03-06  |  126.2 KB  |  3,442 lines
  1. unit Drwsutl3;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, ShellAPI, FileCtrl, DRWSUtl1;
  8.  
  9. const
  10.   EOC_CHANGEDIR = 1;  { Error Operation Code for change directory failure }
  11.   EOC_SOURCECOPY = 2; { Error Operation Code for source copy failure      }
  12.   EOC_DESTCOPY = 3;   { Error Operation Code for destination copy failure }
  13.   EOC_DELETEFILE = 4; { Error Operation Code for file delete failure      }
  14.   EOC_DELETEDIR = 5;  { Error Operation Code for directory delete failure }
  15.   EOC_RENAMEFILE = 6; { Error Operation Code for renaming failure         }
  16.   EOC_MAKEDIR = 7;    { Error Operation Code for MkDir failure            }
  17.   EOC_SETATTR = 8;    { Error Operation Code for Set Attributes failure   }
  18.  
  19.   FAC_COPY = 1;       { File Action Code for recursive copying            }
  20.   FAC_MOVE = 2;       { File Action Code for recursive moving             }
  21.   FAC_DELETE = 3;     { File Action Code for recursive deletion           }
  22.  
  23.   KBMJ_SINGLE = 1;   { Keyboard mouse motion constant for single pixel moves }
  24.   KBMJ_SMALL = 10;    { Keyboard mouse motion constant for single pixel moves }
  25.   KBMJ_LARGE = 50;    { Keyboard mouse motion constant for single pixel moves }
  26.  
  27.   CR_KEYSET = 6; { ID for special keypress cursor }
  28.   CR_NULL = 7;   { ID for Null (blank) cursor     }
  29. type
  30.   { This is a descendant of TFileListbox }
  31.   { Which puts icons of files into the   }
  32.   { Objects array rather than the stand- }
  33.   { ard bitmaps.                         }
  34.   TIconFileListBox = class( TFileListBox )
  35.   public
  36.     { public methods and data }
  37.     procedure ReadFileNames; override;
  38.     function GetNextSelection( SourceDirectory : String;
  39.               var CurrentItem : Integer ) : String;
  40.     constructor Create(AOwner : TComponent); override; { override create    }
  41.     procedure TheDblClick( Sender : TObject );{ This holds override dblclick }
  42.   end;
  43.   TFileWorkBench = class( TComponent )
  44.   public
  45.     GlobalError        : Integer;  { This is used by FMXUCopyFile for er code }
  46.     GlobalErrorType    : Integer;  { This holds the Operation code            }
  47.     function ForceTrailingBackSlash( const TheFileName : String ) : String;
  48.     function StripNonRootTrailingBackSlash(
  49.               const TheFileName : String ) : String;
  50.     procedure GetFileAttributes( TheFile : String; var IsDirectory , IsArchive ,
  51.                 IsVolumeID , IsHidden , IsReadOnly , IsSysFile : Boolean );
  52.     procedure HandleIOException( TheOpCode : Integer; ThePath : String;
  53.                                  TheMessage : String; TheCode : Integer );
  54.     procedure HandleDOSError( TheOpCode : Integer; ThePath : String;
  55.                 TheCode : Integer );
  56.     function CopyFile( TargetPath ,
  57.                DestinationPath : String ) : Boolean;
  58.     procedure ChangeTheDirectory( NewPath : String );
  59.     procedure ChangeTheDriveAndDirectory( NewDrive : Integer );
  60.     procedure CopyTheFile( OldPath , NewPath : String );
  61.     procedure MoveTheFile( OldPath , NewPath : String );
  62.     procedure DeleteTheFile( ThePath : String );
  63.     procedure RenameTheFile( OldPath , NewName : String );
  64.     procedure CreateNewDirectory( NewPath : String );
  65.     procedure RemoveDirectory( ThePath : String );
  66.     procedure SetFileAttributes( TheFile  : String; TheAttributes : Integer );
  67.     procedure RecursivelyCopyDirectory( OldPath , NewPath : String );
  68.     procedure RecursivelyMoveDirectory( OldPath , NewPath : String );
  69.     procedure RecursivelyDeleteDirectory( ThePath : String );
  70.     procedure HandleRecursiveAction( StartingPath , NewPath : String;
  71.                ActionCode : Integer );
  72.   end;
  73.   TFileIconPanel = class( TPanel )
  74.   private
  75.     { Private declarations }
  76.     FHighlightColor : TColor;                 { This holds bright edge bevel }
  77.     FShadowColor    : TColor;                 { This holds dark edge bevel   }
  78.     procedure TheMouseDown(Sender: TObject;
  79.       Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  80.     procedure TheMouseMove( Sender: TObject; Shift: TShiftState;
  81.       X, Y: Integer);
  82.     procedure TheMouseUp(Sender: TObject;
  83.       Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  84.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
  85.      message WM_LBUTTONDBLCLK;
  86.     procedure TheDragOver(Sender, Source: TObject; X,
  87.       Y: Integer; State: TDragState; var Accept: Boolean);
  88.     procedure TheDragDrop(Sender, Source: TObject; X,
  89.       Y: Integer);
  90.   protected                                   { event method procedure.      }
  91.     { Protected declarations }
  92.     procedure Paint; override;                { This allows custom painting  }
  93.   public
  94.     { Public declarations }
  95.     FTheIcon : TIcon;                         { This is the display icon    }
  96.     FTheName : String;                        { This is the filename        }
  97.     FTheLabel : TLabel;                       { This is the display label   }
  98.     Selected : Boolean;                       { This holds selection status }
  99.     constructor Create(AOwner : TComponent); override; { override create    }
  100.     procedure Initialize( PanelX              ,             { Left          }
  101.                           PanelY              ,             { Top           }
  102.                           PanelWidth          ,             { Width         }
  103.                           PanelHeight         ,             { Height        }
  104.                           PanelBevelWidth     ,             { Bevel Width   }
  105.                           LabelFontSize         : Integer;  { Font size     }
  106.                           PanelColor          ,             { Main color    }
  107.                           PanelHighlightColor ,             { Bright color  }
  108.                           PanelShadowColor    ,             { Dark color    }
  109.                           LabelTextColor        : TColor;   { Text color    }
  110.                           TheFilename         ,             { Filename      }
  111.                           LabelFontName         : String;   { Font name     }
  112.                           LabelFontStyle        : TFontStyles;  { Font style}
  113.                           ExtraData             : Integer       );  { Drive }
  114.     destructor Destroy; override;             { override destroy to free    }
  115.   end;
  116.   TFileIconPanelScrollBox = class( TScrollBox )
  117.   public
  118.     { Public methods and data }
  119.     TheFWB              : TFileWorkBench; { Used for file manipulation         }
  120.     IconsNeedRefreshing : Boolean;                   { Flag to redo display    }
  121.     TheIconSize        : Integer;   { Holds Individual Icon size               }
  122.     TheIconSpacing     : Integer;   { Holds total icon footprint               }
  123.     MaxIconsInARow     : Integer;   { Set for screen size.                     }
  124.     TheStoredHandle    : HWnd;
  125.     TheParentForm      : TForm;
  126.     procedure Update;                                { Called to reset display }
  127.     constructor Create( AOwner : TComponent ); override;  { Override inherited }
  128.     procedure ClearTheFIPs;                          { Clears the FIPs safely  }
  129.     procedure AddDriveIcons( var XCounter , YCounter : Integer ); { Add drives }
  130.     procedure GetColorsForFileIcon( TheFile : String;
  131.                var BC , HC , SC , TC : TColor );
  132.     procedure GetIconsForEntireDirectory( TargetPath  : String );
  133.     function GetNextSelection( SourceDirectory : String;
  134.               var CurrentItem : Integer ) : String;
  135.     procedure DisplayRecursiveSearchResults(
  136.       TheStartingDirectory : String );
  137.   end;
  138.   TIOManager = class( TComponent )
  139.   public
  140.     Parent : TForm;
  141.     WhichButton : TMouseButton;
  142.     WhichState  : TShiftState;
  143.     CLState ,
  144.     NLState ,
  145.     SLState   : Boolean;
  146.     function IsCapsLockDown : Boolean;
  147.     function ISNumLockDown : Boolean;
  148.     function IsScrollLockDown : Boolean;
  149.     procedure InitLocks;
  150.     procedure ReadLocks( var TheCL , TheNL , TheSL : Boolean );
  151.     procedure SetLocks( TheCL , TheNL , TheSL : Boolean );
  152.     function WasLeftPressed : Boolean;
  153.     function WasRightPressed : Boolean;
  154.     function WasMiddlePressed : Boolean;
  155.     function WasALTPressed : Boolean;
  156.     function WasSHIFTPressed : Boolean;
  157.     function WasCTRLPressed : Boolean;
  158.     procedure OnF1Pressed(Sender: TObject; var Key: Word;
  159.      Shift: TShiftState);
  160.     procedure OnF2Pressed(Sender: TObject; var Key: Word;
  161.      Shift: TShiftState);
  162.     procedure OnF3Pressed(Sender: TObject; var Key: Word;
  163.      Shift: TShiftState);
  164.     procedure OnF4Pressed(Sender: TObject; var Key: Word;
  165.      Shift: TShiftState);
  166.     procedure OnF5Pressed(Sender: TObject; var Key: Word;
  167.      Shift: TShiftState);
  168.     procedure OnF6Pressed(Sender: TObject; var Key: Word;
  169.      Shift: TShiftState);
  170.     procedure OnF7Pressed(Sender: TObject; var Key: Word;
  171.      Shift: TShiftState);
  172.     procedure OnF8Pressed(Sender: TObject; var Key: Word;
  173.      Shift: TShiftState);
  174.     procedure OnF9Pressed(Sender: TObject; var Key: Word;
  175.      Shift: TShiftState);
  176.     procedure OnF10Pressed(Sender: TObject; var Key: Word;
  177.      Shift: TShiftState);
  178.     procedure OnF11Pressed(Sender: TObject; var Key: Word;
  179.      Shift: TShiftState);
  180.     procedure OnF12Pressed(Sender: TObject; var Key: Word;
  181.      Shift: TShiftState);
  182.  end;
  183.  TMouseManager = class( TComponent )
  184.  public
  185.    TheMX : Integer;
  186.    TheMY : Integer;
  187.    Old_X ,
  188.    Old_Y ,
  189.    New_X ,
  190.    New_Y   : Integer;
  191.    StoredCursor : Integer;
  192.    BitmapCursor  : Boolean;
  193.    IconCursor    : Boolean;
  194.    CursorBMP     : TBitmap;
  195.    CursorIcon    : TIcon;
  196.    IsAnimated    : Boolean;
  197.    TheTimer      : TTimer;
  198.    TheAnimationList : TList;
  199.    CurrentAnimationPointer : Integer;
  200.    AnimationInterval : Integer;
  201.    SavedDC ,
  202.    GlobalDC : HDC;
  203.    GlobalCanvas : TCanvas;
  204.    WorkSpaceBMP : TBitmap;
  205.    BackGroundBMP : TBitmap;
  206.    constructor Create( AOwner : TComponent ); override;
  207.    destructor Destroy; override;
  208.    procedure InitializeNormal;
  209.    procedure InitializeBitmap( TheBmp : TBitmap );
  210.    procedure InitializeIcon( TheIcon : TIcon );
  211.    procedure InitializeAnimated( TheIcon : TIcon; TheInterval : Integer;
  212.                                  TheIconList : TList );
  213.    procedure GetMousePosition( var MouseX , MouseY : Integer );
  214.    procedure SetMousePosition( MouseX , MouseY : Integer );
  215.    procedure MoveSinglePixelLeft;
  216.    procedure MoveSinglePixelRight;
  217.    procedure MoveSinglePixelUp;
  218.    procedure MoveSinglePixelDown;
  219.    procedure MoveSmallJumpLeft;
  220.    procedure MoveSmallJumpRight;
  221.    procedure MoveSmallJumpUp;
  222.    procedure MoveSmallJumpDown;
  223.    procedure MoveLargeJumpLeft;
  224.    procedure MoveLargeJumpRight;
  225.    procedure MoveLargeJumpUp;
  226.    procedure MoveLargeJumpDown;
  227.    procedure StartBitmapCursor( TheX , TheY : Integer );
  228.    procedure MoveBitmapCursor( TheX , TheY : Integer );
  229.    procedure EndBitmapCursor( TheX , TheY : Integer );
  230.    procedure StartIconCursor( TheX , TheY : Integer );
  231.    procedure MoveIconCursor( TheX , TheY : Integer );
  232.    procedure EndIconCursor( TheX , TheY : Integer );
  233.    procedure StartAnimatedIconCursor( TheX , TheY : Integer );
  234.    procedure EndAnimatedIconCursor( TheX , TheY : Integer );
  235.    procedure MoveAnimatedIconCursor( TheX , TheY : Integer );
  236.    procedure TimerAction( Sender : TObject );
  237.  end;
  238.  
  239.   { This procedure gets an icon for a file using FindExecutable  }
  240.   { and ExtractIcon. (assumes file/dir is passed)                }
  241.   procedure GetIconForFile( TheName : String; var TheIcon : TIcon );
  242.   { This procedure spaces out the bitbtn components on a tpanel }
  243.   procedure SpacePanelButtons( WhichPanel : TPanel );
  244.     procedure FMXUCopyFile(const FileName, DestName: String; var GlobalErrorType ,
  245.                GlobalErrorCode : Integer );
  246.  
  247. var TheIOManager : TIOManager;
  248.     TheMouseManager : TMouseManager;
  249.     GlobalAbortFlag : Boolean;
  250.     SavedForm : TForm;
  251.     SavedControl : TFileIconPanel;
  252.     OtherSavedControl : TFileIconPanelScrollbox;
  253.     Savedhandle : HWnd;
  254.     IconDragging : boolean;
  255.     GlobalSource : TObject;
  256.     TheTempBitmap : TBitmap;
  257.     BitmapDragging : boolean;
  258.  
  259. implementation
  260. {$R DRWSUTL3.RES}                 { Import custom resource file }
  261. uses UFMGR17;
  262.  
  263. { It has been edited to return viable error codes!             }
  264. procedure FMXUCopyFile(const FileName, DestName: String; var GlobalErrorType ,
  265.             GlobalErrorCode : Integer );
  266. var
  267.   CopyBuffer: Pointer; { buffer for copying }
  268.   BytesCopied: Longint;
  269.   TheAttr : Integer;
  270.   Source, Dest: Integer; { handles }
  271. const
  272.   ChunkSize: Longint = 8192; { copy in 8K chunks }
  273. begin
  274.   GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
  275.   Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
  276.   if Source < 0 then
  277.   begin  { error creating source file }
  278.     GlobalErrorType := EOC_SOURCECOPY;
  279.     GlobalErrorCode := -IOResult;
  280.     if GlobalErrorCode = 0 then GlobalErrorCode := -157;
  281.     FreeMem( CopyBuffer, ChunkSize );
  282.     exit;
  283.   end;
  284.   Dest := FileCreate(DestName); { create output file; overwrite existing }
  285.   if Dest < 0 then
  286.   begin  { error creating destination file }
  287.     FileClose( Source );
  288.     GlobalErrorType := EOC_DESTCOPY;
  289.     GlobalErrorCode := -IOResult;
  290.     if GlobalErrorCode = 0 then GlobalErrorCode := -159;
  291.     FreeMem( CopyBuffer , ChunkSize );
  292.     exit;
  293.   end;
  294.   {$I-}
  295.   repeat
  296.     BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk}
  297.     if BytesCopied > 0 then { if we read anything... }
  298.     FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
  299.   until BytesCopied < ChunkSize; { until we run out of chunks }
  300.   {$I+}
  301.   GlobalErrorCode := -IOResult;  { get any error code which happens during copying }
  302.   FileClose(Dest); { close the destination file }
  303.   FileClose(Source); { close the source file }
  304.   FreeMem(CopyBuffer, ChunkSize); { free the buffer }
  305. end;
  306.  
  307. { This procedure spaces out the bitbtn components on a tpanel }
  308. procedure SpacePanelButtons( WhichPanel : TPanel );
  309. var TheCalculatedSpacing     ,            { Holds primary spacing }
  310.     TheFullCalculatedSpacing   : Integer; { Holds full spacing    }
  311.     Counter_1                  : Integer; { Loop counter          }
  312.     TotalIBs                   : Integer; { Gets total buttons    }
  313. begin
  314.   { Set up spacing values }
  315.   TotalIBs := WhichPanel.ControlCount;
  316.   TheCalculatedSpacing := (( WhichPanel.Width - 6 - ( TotalIbs * 49 ))
  317.    div ( TotalIbs + 1 ));
  318.   TheFullCalculatedSpacing := TheCalculatedSpacing + 49;
  319.   { Loop through all imported buttons and set their Left values }
  320.   for Counter_1 := 1 to WhichPanel.ControlCount do
  321.   begin
  322.     if Counter_1 = 1 then
  323.     begin
  324.       TBitBtn( WhichPanel.Controls[ Counter_1 - 1 ] ).Left := 3 +
  325.        TheCalculatedSpacing;
  326.     end
  327.     else
  328.     begin
  329.       TBitBtn( WhichPanel.Controls[ Counter_1 - 1 ] ).Left := 3 +
  330.        (( Counter_1 - 1 ) * TheFullCalculatedSpacing ) + TheCalculatedSpacing;
  331.     end;
  332.   end;
  333. end;
  334.  
  335. { This procedure gets an icon for a file using FindExecutable  }
  336. { and ExtractIcon. (assumes file/dir is passed)                }
  337. procedure GetIconForFile( TheName : String; var TheIcon : TIcon );
  338. var TheExt           : String; { File extension holder }
  339.     TheOtherPChar  ,           { Windows ASCIIZ string }
  340.     ThePChar         : PChar;  { Windows ASCIIZ string }
  341.     Dummy : Word;
  342. begin
  343.   { Check for directory and if so get directory icon from RES file }
  344.   if (( FileGetAttr( TheName ) and faDirectory ) = faDirectory ) then
  345.   begin
  346.     { Set up the PChar to communicate with Windows }
  347.     GetMem( TheOtherPChar , 255 );
  348.     { Convert Pascal-style string to ASCIIZ Pchar }
  349.     StrPCopy( TheOtherPChar , 'DIRECTORY' );
  350.     { Use API call to return icon handle of Icon Resource in FILECTRL.RES }
  351.     TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  352.     { Release memory from PChar }
  353.     FreeMem( TheOtherPChar , 255 );
  354.     { Leave }
  355.     exit;
  356.   end;
  357.   { Assume archive file; get its extension }
  358.   TheExt := Uppercase( ExtractFileExt( TheName ));
  359.   { If not an executable/image file then use FindExecutable to get icon }
  360.   if (( TheExt <> '.EXE' ) and ( TheExt <> '.BAT' ) and
  361.       ( TheExt <> '.PIF' ) and ( TheExt <> '.COM' )) then
  362.   begin
  363.     { Grab three chunks of memory }
  364.     GetMem( ThePChar , 255 );
  365.     { Set up the name and its directory in Windows string formats }
  366.     StrPCopy( ThePChar, TheName );
  367.     Dummy := 65535;
  368.     {**** Windows 95 Specialized call ****** }
  369.     TheIcon.Handle := ExtractAssociatedIcon( hInstance , ThePChar , Dummy );
  370.     if TheIcon.Handle = 0 then
  371.     begin
  372.       GetMem( TheOtherPChar , 255 );
  373.       StrPCopy( TheOtherPChar , 'NOICON' );
  374.       TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  375.       FreeMem( TheOtherPChar , 255 );
  376.       exit;
  377.     end;
  378.     FreeMem( ThePChar , 255 );
  379.   end
  380.   else
  381.   { Assume Windows Executable file, so get icon from it with ExtractIcon API }
  382.   begin
  383.     GetMem( ThePChar , 255 );
  384.     StrPCopy( ThePChar , TheName );
  385.     { Try to get first icon for file }
  386.     Dummy := 65535;
  387.     TheIcon.Handle := ExtractAssociatedIcon( hInstance , ThePChar , Dummy );
  388.     FreeMem( ThePChar , 255 );
  389.     { If handle is 0 invalid icon format so use default from RES file }
  390.     if TheIcon.Handle = 0 then
  391.     begin
  392.       GetMem( TheOtherPChar , 255 );
  393.       StrPCopy( TheOtherPChar , 'NOICON' );
  394.       TheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  395.       FreeMem( TheOtherPChar , 255 );
  396.       exit;
  397.     end;
  398.   end;
  399. end;
  400.  
  401. { This creates the TMouseManager and inits vars to null }
  402. constructor TMouseManager.Create( AOwner : TComponent );
  403. begin
  404.   { Call inherited FIRST! }
  405.   inherited Create( AOwner );
  406.   { Set all variables to 0 , false or nil }
  407.   TheMX := 0;
  408.   TheMY := 0;
  409.   Old_X  := 0;
  410.   Old_Y  := 0;
  411.   New_X  := 0;
  412.   New_Y  := 0;
  413.   StoredCursor := 0;
  414.   BitmapCursor  := false;
  415.   IconCursor    := false;
  416.   CursorBMP     := nil;
  417.   CursorIcon    := nil;
  418.   IsAnimated    := false;
  419.   TheTimer      := nil;
  420.   TheAnimationList := nil;
  421.   CurrentAnimationPointer := 0;
  422.   AnimationInterval := 0;
  423.   SavedDC := 0;
  424.   GlobalDC := 0;
  425.   GlobalCanvas := nil;
  426.   WorkSpaceBMP := nil;
  427.   BackGroundBMP := nil;
  428. end;
  429.  
  430. { This destroys the tmousemanager and releases all resources }
  431. destructor TMouseManager.Destroy;
  432. begin
  433.   { Free any assigned resources (the moving bmp ones already are gone) }
  434.   if assigned( TheTimer ) then
  435.    TheTimer.Free;
  436.   if assigned( TheAnimationList ) then
  437.    TheAnimationList.Free;
  438.   Inherited Destroy;
  439. end;
  440.  
  441. { This sets up the mouse manager for normal cursor operations }
  442. procedure TMouseManager.InitializeNormal;
  443. var TheMP : TPoint;
  444. begin
  445.   { Reset State Variables }
  446.   BitmapCursor := false;
  447.   IconCursor := false;
  448.   IsAnimated := false;
  449.   { Call API to get mouse coordinates }
  450.   GetCursorPos( TheMP );
  451.   { Store the coordinates for later use }
  452.   TheMX := TheMP.X;
  453.   TheMY := TheMP.Y;
  454.   Old_X := TheMX;
  455.   Old_Y := TheMY;
  456.   New_X := TheMX;
  457.   New_Y := TheMY;
  458. end;
  459.  
  460. { This procedure initializes a bitmap cursor }
  461. procedure TMouseManager.InitializeBitmap( TheBmp : TBitmap );
  462. begin
  463.   InitializeNormal;
  464.   CursorBMP := TheBMP;
  465.   BitmapCursor := true;
  466. end;
  467.  
  468. { This procedure initalizes an icon cursor }
  469. procedure TMouseManager.InitializeIcon( TheIcon : TIcon );
  470. begin
  471.   InitializeNormal;
  472.   CursorIcon := TheIcon;
  473.   IconCursor := true;
  474. end;
  475.  
  476. { This procedure initializes an animated icon cursor }
  477. procedure TMouseManager.InitializeAnimated( TheIcon : TIcon;
  478.            TheInterval : Integer; TheIconList : TList );
  479. begin
  480.   InitializeNormal;
  481.   CursorIcon := TheIcon;
  482.   IconCursor := true;
  483.   IsAnimated := true;
  484.   AnimationInterval := TheInterval;
  485.   TheAnimationList := TheIconList;
  486.   TheTimer := TTimer.Create( Self );
  487.   TheTimer.Enabled := false;
  488.   TheTimer.Interval := AnimationInterval;
  489.   TheTimer.OnTimer := TimerAction;
  490. end;
  491.  
  492. { This procedure returns the current stored mouse position }
  493. procedure TMouseManager.GetMousePosition( var MouseX , MouseY : Integer );
  494. begin
  495.   { Return stored position rather than call API }
  496.   MouseX := TheMX;
  497.   MouseY := TheMY;
  498. end;
  499.  
  500. { This procedure sets the Mouse Position internally }
  501. procedure TMouseManager.SetMousePosition( MouseX , MouseY : Integer );
  502. begin
  503.   { Set internal coordinates; don't call API }
  504.   TheMX := MouseX;
  505.   TheMY := MouseY;
  506. end;
  507.  
  508. { This procedure is used to drive the mouse with the keyboard }
  509. procedure TMouseManager.MoveSinglePixelLeft;
  510. begin
  511.   { Use internal coordinates and check for screen wrapping }
  512.   if TheMX > KBMJ_SINGLE then
  513.   begin
  514.     { Not wrapped; move along one unit to the left }
  515.     TheMX := TheMX - KBMJ_SINGLE;
  516.     SetCursorPos( TheMX , TheMY );
  517.   end
  518.   else
  519.   begin
  520.     { Wrapped; jump to right and move back one unit }
  521.     TheMX := Screen.Width - KBMJ_SINGLE;
  522.     SetCursorPos( TheMX , TheMY );
  523.   end;
  524. end;
  525.  
  526. { This procedure is used to drive the mouse with the keyboard }
  527. procedure TMouseManager.MoveSinglePixelRight;
  528. begin
  529.   { Use internal coordinates and check for screen wrapping }
  530.   if TheMX < ( Screen.Width - KBMJ_SINGLE ) then
  531.   begin
  532.     { Not wrapped; move along one unit to the right }
  533.     TheMX := TheMX + KBMJ_SINGLE;
  534.     SetCursorPos( TheMX , TheMY );
  535.   end
  536.   else
  537.   begin
  538.     { Wrapped; jump to left and move in one unit }
  539.     TheMX := KBMJ_SINGLE;
  540.     SetCursorPos( TheMX , TheMY );
  541.   end;
  542. end;
  543.  
  544. { This procedure is used to drive the mouse with the keyboard }
  545. procedure TMouseManager.MoveSinglePixelUp;
  546. begin
  547.   { Use internal coordinates and check for screen wrapping }
  548.   if TheMY > KBMJ_SINGLE then
  549.   begin
  550.     { Not wrapped; move along one unit to the top }
  551.     TheMY := TheMY - KBMJ_SINGLE;
  552.     SetCursorPos( TheMX , TheMY );
  553.   end
  554.   else
  555.   begin
  556.     { Wrapped; jump to bottom and move back one unit }
  557.     TheMY := Screen.Height - KBMJ_SINGLE;
  558.     SetCursorPos( TheMX , TheMY );
  559.   end;
  560. end;
  561.  
  562. { This procedure is used to drive the mouse with the keyboard }
  563. procedure TMouseManager.MoveSinglePixelDown;
  564. begin
  565.   { Use internal coordinates and check for screen wrapping }
  566.   if TheMY < ( Screen.Height - KBMJ_SINGLE ) then
  567.   begin
  568.     { Not wrapped; move along one unit to the bottom }
  569.     TheMY := TheMY + KBMJ_SINGLE;
  570.     SetCursorPos( TheMX , TheMY );
  571.   end
  572.   else
  573.   begin
  574.     { Wrapped; jump to top and move back one unit }
  575.     TheMY := KBMJ_SINGLE;
  576.     SetCursorPos( TheMX , TheMY );
  577.   end;
  578. end;
  579.  
  580. { This procedure is used to drive the mouse with the keyboard }
  581. procedure TMouseManager.MoveSmallJumpLeft;
  582. begin
  583.   { Use internal coordinates and check for screen wrapping }
  584.   if TheMX > KBMJ_SMALL then
  585.   begin
  586.     { Not wrapped; move along one unit to the left }
  587.     TheMX := TheMX - KBMJ_SMALL;
  588.     SetCursorPos( TheMX , TheMY );
  589.   end
  590.   else
  591.   begin
  592.     { Wrapped; jump to right and move back the unit }
  593.     TheMX := Screen.Width - KBMJ_SMALL;
  594.     SetCursorPos( TheMX , TheMY );
  595.   end;
  596. end;
  597.  
  598. { This procedure is used to drive the mouse with the keyboard }
  599. procedure TMouseManager.MoveSmallJumpRight;
  600. begin
  601.   { Use internal coordinates and check for screen wrapping }
  602.   if TheMX < ( Screen.Width - KBMJ_SMALL ) then
  603.   begin
  604.     { Not wrapped; move along one unit to the right }
  605.     TheMX := TheMX + KBMJ_SMALL;
  606.     SetCursorPos( TheMX , TheMY );
  607.   end
  608.   else
  609.   begin
  610.     { Wrapped; jump to left and move in one unit }
  611.     TheMX := KBMJ_SMALL;
  612.     SetCursorPos( TheMX , TheMY );
  613.   end;
  614. end;
  615.  
  616. { This procedure is used to drive the mouse with the keyboard }
  617. procedure TMouseManager.MoveSmallJumpUp;
  618. begin
  619.   { Use internal coordinates and check for screen wrapping }
  620.   if TheMY > KBMJ_SMALL then
  621.   begin
  622.     { Not wrapped; move along one unit to the top }
  623.     TheMY := TheMY - KBMJ_SMALL;
  624.     SetCursorPos( TheMX , TheMY );
  625.   end
  626.   else
  627.   begin
  628.     { Wrapped; jump to bottom and move back one unit }
  629.     TheMY := Screen.Height - KBMJ_SMALL;
  630.     SetCursorPos( TheMX , TheMY );
  631.   end;
  632. end;
  633.  
  634. { This procedure is used to drive the mouse with the keyboard }
  635. procedure TMouseManager.MoveSmallJumpDown;
  636. begin
  637.   { Use internal coordinates and check for screen wrapping }
  638.   if TheMY < ( Screen.Height - KBMJ_SMALL ) then
  639.   begin
  640.     { Not wrapped; move along one unit to the bottom }
  641.     TheMY := TheMY + KBMJ_SMALL;
  642.     SetCursorPos( TheMX , TheMY );
  643.   end
  644.   else
  645.   begin
  646.     { Wrapped; jump to top and move back one unit }
  647.     TheMY := KBMJ_SMALL;
  648.     SetCursorPos( TheMX , TheMY );
  649.   end;
  650. end;
  651.  
  652. { This procedure is used to drive the mouse with the keyboard }
  653. procedure TMouseManager.MoveLargeJumpLeft;
  654. begin
  655.   { Use internal coordinates and check for screen wrapping }
  656.   if TheMX > KBMJ_LARGE then
  657.   begin
  658.     { Not wrapped; move along the unit to the left }
  659.     TheMX := TheMX - KBMJ_LARGE;
  660.     SetCursorPos( TheMX , TheMY );
  661.   end
  662.   else
  663.   begin
  664.     { Wrapped; jump to right and move back the unit }
  665.     TheMX := Screen.Width - KBMJ_LARGE;
  666.     SetCursorPos( TheMX , TheMY );
  667.   end;
  668. end;
  669.  
  670. { This procedure is used to drive the mouse with the keyboard }
  671. procedure TMouseManager.MoveLargeJumpRight;
  672. begin
  673.   { Use internal coordinates and check for screen wrapping }
  674.   if TheMX < ( Screen.Width - KBMJ_LARGE ) then
  675.   begin
  676.     { Not wrapped; move along one unit to the right }
  677.     TheMX := TheMX + KBMJ_LARGE;
  678.     SetCursorPos( TheMX , TheMY );
  679.   end
  680.   else
  681.   begin
  682.     { Wrapped; jump to left and move in one unit }
  683.     TheMX := KBMJ_LARGE;
  684.     SetCursorPos( TheMX , TheMY );
  685.   end;
  686. end;
  687.  
  688. { This procedure is used to drive the mouse with the keyboard }
  689. procedure TMouseManager.MoveLargeJumpUp;
  690. begin
  691.   { Use internal coordinates and check for screen wrapping }
  692.   if TheMY > KBMJ_LARGE then
  693.   begin
  694.     { Not wrapped; move along one unit to the top }
  695.     TheMY := TheMY - KBMJ_LARGE;
  696.     SetCursorPos( TheMX , TheMY );
  697.   end
  698.   else
  699.   begin
  700.     { Wrapped; jump to bottom and move back one unit }
  701.     TheMY := Screen.Height - KBMJ_LARGE;
  702.     SetCursorPos( TheMX , TheMY );
  703.   end;
  704. end;
  705.  
  706. { This procedure is used to drive the mouse with the keyboard }
  707. procedure TMouseManager.MoveLargeJumpDown;
  708. begin
  709.   { Use internal coordinates and check for screen wrapping }
  710.   if TheMY < ( Screen.Height - KBMJ_LARGE ) then
  711.   begin
  712.     { Not wrapped; move along one unit to the bottom }
  713.     TheMY := TheMY + KBMJ_LARGE;
  714.     SetCursorPos( TheMX , TheMY );
  715.   end
  716.   else
  717.   begin
  718.     { Wrapped; jump to top and move back one unit }
  719.     TheMY := KBMJ_LARGE;
  720.     SetCursorPos( TheMX , TheMY );
  721.   end;
  722. end;
  723.  
  724. { This procedure sets up the bitmaps and global HDC prior to moving a }
  725. { Bitmap cursor.                                                      }
  726. procedure TMouseManager.StartBitmapCursor( TheX , TheY : Integer );
  727. var WorkingPoint1 ,
  728.     WorkingPoint2 : TPoint;
  729. begin
  730.   GlobalDC := GetDC( 0 );
  731.   WorkspaceBMP := TBitmap.Create;
  732.   WorkspaceBMP.Width := Screen.Width;
  733.   WorkSpaceBMP.Height := Screen.Height;
  734.   BitBlt( WorkspaceBMP.Canvas.Handle , 0 , 0 , Screen.Width , Screen.Height ,
  735.    GlobalDC , 0 , 0 , SrcCopy );
  736.   BackgroundBMP := TBitmap.Create;
  737.   BackgroundBMP.Width := CursorBMP.Width;
  738.   BackgroundBMP.Height := CursorBMP.Height;
  739.   New_X := TheX;
  740.   New_Y := TheY;
  741.   StoredCursor := Screen.Cursor;
  742.   Screen.Cursor := CR_NULL;
  743.   {Grab the background image}
  744.   WorkingPoint1.X := New_X - ( CursorBMP.Width div 2 );
  745.   WorkingPoint1.Y := New_Y - ( CursorBMP.Height div 2 );
  746.   WorkingPoint2.X := New_X + ( CursorBMP.Width - ( CursorBMP.Width div 2 ));
  747.   WorkingPoint2.Y := New_Y + ( CursorBMP.Height - ( CursorBMP.Height div 2 ));
  748.   BackgroundBmp.Canvas.CopyRect( Rect( 0 , 0 , CursorBMP.Width , CursorBMP.Height ) ,
  749.    WorkspaceBMP.Canvas , Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X ,
  750.     WorkingPoint2.Y ));
  751.   {Put the cursor bitmap onto the workspace canvas}
  752.   with WorkspaceBMP.Canvas do
  753.   begin
  754.     CopyMode := cmSrcCopy;
  755.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  756.      CursorBMP.Canvas , Rect( 0 , 0 , CursorBMP.Width , CursorBMP.Height ));
  757.   end;
  758.   {Copy the workspace bitmap onto the visible screen}
  759.     BitBlt( GlobalDC , WorkingPoint1.X , WorkingPoint1.Y , CursorBMP.Width , CursorBMP.Height ,
  760.      WorkspaceBMP.Canvas.Handle , WorkingPoint1.X , WorkingPoint1.Y , SrcCopy );
  761.   Old_X := New_X;
  762.   Old_Y := New_Y;
  763. end;
  764.  
  765. { This procedure moves a bitmap cursor according to the imported New coords }
  766. procedure TMouseManager.MoveBitmapCursor( TheX , TheY : Integer );
  767. var StartX,
  768.     StartY,
  769.     XDiff,
  770.     YDiff : Integer;
  771.     WorkingPoint1 ,
  772.     WorkingPoint2  : TPoint;
  773. begin
  774.   New_X := TheX;
  775.   New_Y := TheY;
  776.   WorkingPoint1.X := Old_X - ( CursorBMP.Width div 2 );
  777.   WorkingPoint1.Y := Old_Y - ( CursorBMP.Height div 2 );
  778.   WorkingPoint2.X := Old_X + ( CursorBMP.Width - ( CursorBMP.Width div 2 ));
  779.   WorkingPoint2.Y := Old_Y + ( CursorBMP.Height - ( CursorBMP.Height div 2 ));
  780.   with WorkspaceBMP.Canvas do
  781.   begin
  782.     CopyMode := cmSrcCopy;
  783.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  784.       BackgroundBMP.Canvas , Rect( 0 , 0 , CursorBMP.Width , CursorBMP.Height ));
  785.   end;
  786.   {Put the saved bitmap onto the workspace canvas}
  787.   with WorkspaceBMP.Canvas do
  788.   begin
  789.     CopyMode := cmSrcCopy;
  790.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  791.      BackgroundBMP.Canvas , Rect( 0 , 0 , CursorBMP.Width , CursorBMP.Height ));
  792.   end;
  793.   {Grab the background image}
  794.   WorkingPoint1.X := New_X - ( CursorBMP.Width div 2 );
  795.   WorkingPoint1.Y := New_Y - ( CursorBMP.Height div 2 );
  796.   WorkingPoint2.X := New_X + ( CursorBMP.Width - ( CursorBMP.Width div 2 ));
  797.   WorkingPoint2.Y := New_Y + ( CursorBMP.Height - ( CursorBMP.Height div 2 ));
  798.   BackgroundBmp.Canvas.CopyRect( Rect( 0 , 0 , CursorBMP.Width , CursorBMP.Height ) ,
  799.    WorkspaceBMP.Canvas , Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X ,
  800.     WorkingPoint2.Y ));
  801.   {Put the cursor bitmap onto the workspace canvas}
  802.   with WorkspaceBMP.Canvas do
  803.   begin
  804.     CopyMode := cmSrcCopy;
  805.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  806.      CursorBMP.Canvas , Rect( 0 , 0 , CursorBMP.Width , CursorBMP.Height ));
  807.   end;
  808.   {Copy the workspace bitmap onto the visible screen}
  809.   if New_X > Old_X then StartX := Old_X else StartX := New_X;
  810.   if New_Y > Old_Y then StartY := Old_Y else StartY := New_Y;
  811.   XDiff := Abs( Old_X - New_X );
  812.   YDiff := Abs( Old_Y - New_Y );
  813.   {Grab the background image}
  814.   WorkingPoint1.X := StartX - ( CursorBMP.Width div 2 );
  815.   WorkingPoint1.Y := StartY - ( CursorBMP.Height div 2 );
  816.   BitBlt( GlobalDC , WorkingPoint1.X , WorkingPoint1.Y , CursorBMP.Width + XDiff ,
  817.    CursorBMP.Height + YDiff , WorkspaceBMP.Canvas.Handle , WorkingPoint1.X ,
  818.     WorkingPoint1.Y , SrcCopy );
  819.   Old_X := New_X;
  820.   Old_Y := New_Y;
  821. end;
  822.  
  823. { This procedure releases a bitmap cursor and frees its DC }
  824. procedure TMouseManager.EndBitmapCursor( TheX , TheY : Integer );
  825. var WorkingPoint1 ,
  826.     WorkingPoint2 : TPoint;
  827. begin
  828.   BitmapCursor := false;
  829.   WorkingPoint1.X := Old_X - ( CursorBMP.Width div 2 );
  830.   WorkingPoint1.Y := Old_Y - ( CursorBMP.Height Div 2 );
  831.   WorkingPoint2.X := Old_X + ( CursorBMP.Width - ( CursorBMP.Width div 2 ));
  832.   WorkingPoint2.Y := Old_Y + ( CursorBMP.Height - ( CursorBMP.Height div 2 ));
  833.   {Put the saved bitmap onto the workspace canvas}
  834.   with WorkspaceBMP.Canvas do
  835.   begin
  836.     CopyMode := cmSrcCopy;
  837.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  838.        BackGroundBMP.Canvas , Rect( 0 , 0 , CursorBMP.Width ,  CursorBMP.Height ));
  839.   end;
  840.   {Copy the workspace bitmap onto the visible screen}
  841.   BitBlt( GlobalDC , WorkingPoint1.X , WorkingPoint1.Y , CursorBMP.Width , CursorBMP.Height ,
  842.    WorkspaceBMP.Canvas.handle , WorkingPoint1.X , WorkingPoint1.Y , SrcCopy );
  843.   ReleaseDC( 0 , GlobalDC );
  844.   Screen.Cursor := StoredCursor;
  845. end;
  846.  
  847. { This procedure starts the process of displaying an icon cursor }
  848. procedure TMouseManager.StartIconCursor( TheX , TheY : Integer );
  849. var WorkingPoint1 ,
  850.     WorkingPoint2 : TPoint;
  851. begin
  852.   GlobalDC := GetDC( 0 );
  853.   WorkspaceBMP := TBitmap.Create;
  854.   WorkspaceBMP.Width := Screen.Width;
  855.   WorkSpaceBMP.Height := Screen.Height;
  856.   BitBlt( WorkspaceBMP.Canvas.Handle , 0 , 0 , Screen.Width , Screen.Height ,
  857.    GlobalDC , 0 , 0 , SrcCopy );
  858.   BackgroundBMP := TBitmap.Create;
  859.   BackgroundBMP.Width := 33;
  860.   BackgroundBMP.Height := 33;
  861.   New_X := TheX;
  862.   New_Y := TheY;
  863.   StoredCursor := Screen.Cursor;
  864.   Screen.Cursor := CR_NULL;
  865.   {Grab the background image}
  866.   WorkingPoint1.X := New_X - 16;
  867.   WorkingPoint1.Y := New_Y - 16;
  868.   WorkingPoint2.X := New_X + 17;
  869.   WorkingPoint2.Y := New_Y + 17;
  870.   BackgroundBmp.Canvas.CopyRect( Rect( 0 , 0 , 33 , 33 ) , WorkspaceBMP.Canvas ,
  871.      Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ));
  872.   {Put the icon onto the workspace canvas}
  873.   with WorkspaceBMP.Canvas do
  874.   begin
  875.     Draw( WorkingPoint1.X , WorkingPoint1.Y , CursorIcon );
  876.   end;
  877.   {Copy the workspace bitmap onto the visible screen}
  878.     BitBlt( GlobalDC , WorkingPoint1.X , WorkingPoint1.Y , 33 , 33 ,
  879.      WorkspaceBMP.Canvas.Handle , WorkingPoint1.X , WorkingPoint1.Y , SrcCopy );
  880.   Old_X := New_X;
  881.   Old_Y := New_Y;
  882. end;
  883.  
  884. { This procedure moves the icon cursor in response to mouse moves }
  885. procedure TMouseManager.MoveIconCursor( TheX , TheY : Integer );
  886. var StartX,
  887.     StartY,
  888.     XDiff,
  889.     YDiff : Integer;
  890.     WorkingPoint1 ,
  891.     WorkingPoint2  : TPoint;
  892. begin
  893.   New_X := TheX;
  894.   New_Y := TheY;
  895.   {Put the saved bitmap onto the workspace canvas}
  896.   WorkingPoint1.X := Old_X - 16;
  897.   WorkingPoint1.Y := Old_Y - 16;
  898.   WorkingPoint2.X := Old_X + 17;
  899.   WorkingPoint2.Y := Old_Y + 17;
  900.   with WorkspaceBMP.Canvas do
  901.   begin
  902.     CopyMode := cmSrcCopy;
  903.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  904.       BackgroundBMP.Canvas , Rect( 0 , 0 , 33 , 33 ));
  905.   end;
  906.   {Grab the background image}
  907.   WorkingPoint1.X := New_X - 16;
  908.   WorkingPoint1.Y := New_Y - 16;
  909.   WorkingPoint2.X := New_X + 17;
  910.   WorkingPoint2.Y := New_Y + 17;
  911.   BackgroundBMP.Canvas.CopyRect( Rect( 0 , 0 , 33 , 33 ) , WorkspaceBMP.Canvas ,
  912.      Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ));
  913.   {Put the icon onto the workspace canvas}
  914.   with WorkspaceBMP.Canvas do
  915.   begin
  916.     Draw( WorkingPoint1.X , WorkingPoint1.Y , CursorIcon );
  917.   end;
  918.   {Copy the workspace bitmap onto the visible screen}
  919.     if New_X > Old_X then StartX := Old_X else StartX := New_X;
  920.     if New_Y > Old_Y then StartY := Old_Y else StartY := New_Y;
  921.     XDiff := Abs( Old_X - New_X );
  922.     YDiff := Abs( Old_Y - New_Y );
  923.     {Grab the background image}
  924.     WorkingPoint1.X := StartX - 16;
  925.     WorkingPoint1.Y := StartY - 16;
  926.     BitBlt( GlobalDC , WorkingPoint1.X , WorkingPoint1.Y , 33 + XDiff , 33 + YDiff ,
  927.      WorkspaceBMP.Canvas.Handle , WorkingPoint1.X , WorkingPoint1.Y , SrcCopy );
  928.   Old_X := New_X;
  929.   Old_Y := New_Y;
  930. end;
  931.  
  932. { This procedure ends the icon cursor movement and frees its DCs }
  933. procedure TMouseManager.EndIconCursor( TheX , TheY : Integer );
  934. var WorkingPoint1 ,
  935.     WorkingPoint2 : TPoint;
  936. begin
  937.   IconCursor := false;
  938.   WorkingPoint1.X := Old_X - 16;
  939.   WorkingPoint1.Y := Old_Y - 16;
  940.   WorkingPoint2.X := Old_X + 17;
  941.   WorkingPoint2.Y := Old_Y + 17;
  942.   {Put the saved bitmap onto the workspace canvas}
  943.   with WorkspaceBMP.Canvas do
  944.   begin
  945.     CopyMode := cmSrcCopy;
  946.     CopyRect( Rect( WorkingPoint1.X , WorkingPoint1.Y , WorkingPoint2.X , WorkingPoint2.Y ),
  947.        BackGroundBMP.Canvas , Rect( 0 , 0 , 33 ,  33 ));
  948.   end;
  949.   {Copy the workspace bitmap onto the visible screen}
  950.   BitBlt( GlobalDC , WorkingPoint1.X , WorkingPoint1.Y , 33 , 33 ,
  951.    WorkspaceBMP.Canvas.handle , WorkingPoint1.X , WorkingPoint1.Y , SrcCopy );
  952.   ReleaseDC( 0 , GlobalDC );
  953.   Screen.Cursor := StoredCursor;
  954. end;
  955.  
  956. { This procedure starts the animated icon cursor }
  957. procedure TMouseManager.StartAnimatedIconCursor( TheX , TheY : Integer );
  958. begin
  959.   StartIconCursor( TheX , TheY );
  960.   TheTimer.Enabled := true;
  961.   CurrentAnimationPointer := 1;
  962. end;
  963.  
  964. { This procedue ends the animated icon cursor }
  965. procedure TMouseManager.EndAnimatedIconCursor( TheX , TheY : Integer );
  966. begin
  967.   EndIconCursor( TheX , TheY );
  968.   TheTimer.Enabled := false;
  969.   CursorIcon := TIcon( TheAnimationList[ 0 ] );
  970. end;
  971.  
  972. { This procedure moves the animated icon cursor }
  973. procedure TMouseManager.MoveAnimatedIconCursor( TheX , TheY : Integer );
  974. begin
  975.   MoveIconCursor( TheX , TheY );
  976. end;
  977.  
  978. { This procedure switches icons on timer events and prompts a redraw }
  979. procedure TMouseManager.TimerAction( Sender : TObject );
  980. begin
  981.   Inc( CurrentAnimationPointer );     
  982.   if CurrentAnimationPointer > TheAnimationList.Count then
  983.    CurrentAnimationPointer := 1;
  984.   CursorIcon := TIcon( TheAnimationList[ CurrentAnimationPointer - 1 ] );
  985.   MoveIconCursor( Old_X , Old_Y );
  986. end;
  987.  
  988. { This function returns true if CAPSLOCK is down }
  989. function TIoManager.IsCapsLockDown : Boolean;
  990. begin
  991.   if CLState then result := true else result := false;
  992. end;
  993.  
  994. { This function returns true if NUMLOCK is down }
  995. function TIoManager.ISNumLockDown : Boolean;
  996. begin
  997.   if NLState then result := true else result := false;
  998. end;
  999.  
  1000. { This function returns true if SCROLLLOCK is down }
  1001. function TIoManager.IsScrollLockDown : Boolean;
  1002. begin
  1003.   if SLState then result := true else result := false;
  1004. end;
  1005.  
  1006. { this function gets the values for CLState, NLState, and SLState }
  1007. procedure TIoManager.InitLocks;
  1008. var TheKeys : TKeyboardState;
  1009. begin
  1010.   GetKeyBoardState( TheKeys );
  1011.   CLState := (( TheKeys[ VK_Capital ] mod 2 ) = 1 );
  1012.   NLState := (( TheKeys[ VK_Numlock ] mod 2 ) = 1 );
  1013.   CLState := (( TheKeys[ VK_Scroll ] mod 2 ) = 1 );
  1014. end;
  1015.  
  1016. { This procedure returns the state of the three lock variables }
  1017. procedure TIoManager.ReadLocks( var TheCL , TheNL , TheSL : Boolean );
  1018. begin
  1019.   TheCL := CLState;
  1020.   TheNL := NLState;
  1021.   TheSL := SLState;
  1022. end;
  1023.  
  1024. { This procedure sets the state of the three lock variables to the imported vals }
  1025. procedure TIoManager.SetLocks( TheCL , TheNL , TheSL : Boolean );
  1026. var TheKeys : TKeyBoardState;
  1027. begin
  1028.   GetKeyBoardState( TheKeys );
  1029.   CLState := TheCL;
  1030.   NLState := TheNL;
  1031.   SLState := TheSL;
  1032.   if ClState then TheKeys[ VK_Capital ] := 1 else
  1033.    TheKeys[ VK_Capital ] := 0;
  1034.   if NLState then TheKeys[ VK_Numlock ] := 1 else
  1035.    TheKeys[ VK_Numlock ] := 0;
  1036.   if SLState then TheKeys[ VK_Scroll ] := 1 else
  1037.    TheKeys[ VK_Scroll ] := 0;
  1038.   SetKeyBoardState( TheKeys );
  1039. end;
  1040.  
  1041. { This procedure handles pressing of F1 for CCFileManagerForm }
  1042. procedure TIoManager.OnF1Pressed(Sender: TObject; var Key: Word;
  1043.   Shift: TShiftState);
  1044. begin
  1045.   MessageDlg( 'Help not implemented!' , mtInformation,[mbok],0);
  1046. end;
  1047.  
  1048. { This procedure handles pressing of F2 for CCFileManagerForm }
  1049. procedure TIoManager.OnF2Pressed(Sender: TObject; var Key: Word;
  1050.   Shift: TShiftState);
  1051. begin
  1052.   TCCFileMgrForm( Parent ).BitBtn1Click( Sender );
  1053. end;
  1054.  
  1055. { This procedure handles pressing of F3 for CCFileManagerForm }
  1056. procedure TIoManager.OnF3Pressed(Sender: TObject; var Key: Word;
  1057.   Shift: TShiftState);
  1058. begin
  1059.   TCCFileMgrForm( Parent ).BitBtn2Click( Sender );
  1060. end;
  1061.  
  1062. { This procedure handles pressing of F4 for CCFileManagerForm }
  1063. procedure TIoManager.OnF4Pressed(Sender: TObject; var Key: Word;
  1064.   Shift: TShiftState);
  1065. begin
  1066.   TCCFileMgrForm( Parent ).BitBtn3Click( Sender );
  1067. end;
  1068.  
  1069. { This procedure handles pressing of F5 for CCFileManagerForm }
  1070. procedure TIoManager.OnF5Pressed(Sender: TObject; var Key: Word;
  1071.   Shift: TShiftState);
  1072. begin
  1073.   TCCFileMgrForm( Parent ).BitBtn4Click( Sender );
  1074. end;
  1075.  
  1076. { This procedure handles pressing of F6 for CCFileManagerForm }
  1077. procedure TIoManager.OnF6Pressed(Sender: TObject; var Key: Word;
  1078.   Shift: TShiftState);
  1079. begin
  1080.   TCCFileMgrForm( Parent ).BitBtn5Click( Sender );
  1081. end;
  1082.  
  1083. { This procedure handles pressing of F7 for CCFileManagerForm }
  1084. procedure TIoManager.OnF7Pressed(Sender: TObject; var Key: Word;
  1085.   Shift: TShiftState);
  1086. begin
  1087.   TCCFileMgrForm( Parent ).BitBtn9Click( Sender );
  1088. end;
  1089.  
  1090. { This procedure handles pressing of F8 for CCFileManagerForm }
  1091. procedure TIoManager.OnF8Pressed(Sender: TObject; var Key: Word;
  1092.   Shift: TShiftState);
  1093. begin
  1094.   TCCFileMgrForm( Parent ).BitBtn6Click( Sender );
  1095. end;
  1096.  
  1097. { This procedure handles pressing of F9 for CCFileManagerForm }
  1098. procedure TIoManager.OnF9Pressed(Sender: TObject; var Key: Word;
  1099.   Shift: TShiftState);
  1100. begin
  1101.   TCCFileMgrForm( Parent ).Update;
  1102. end;
  1103.  
  1104. { This procedure handles pressing of F10 for CCFileManagerForm }
  1105. procedure TIoManager.OnF10Pressed(Sender: TObject; var Key: Word;
  1106.   Shift: TShiftState);
  1107. begin
  1108.   TCCFileMgrForm( Parent ).BitBtn7Click( Sender );
  1109. end;
  1110.  
  1111. { This procedure handles pressing of F11 for CCFileManagerForm }
  1112. procedure TIoManager.OnF11Pressed(Sender: TObject; var Key: Word;
  1113.   Shift: TShiftState);
  1114. begin
  1115.   TCCFileMgrForm( Parent ).BitBtn8Click( Sender );
  1116. end;
  1117.  
  1118. { This procedure handles pressing of F12 for CCFileManagerForm }
  1119. procedure TIoManager.OnF12Pressed(Sender: TObject; var Key: Word;
  1120.   Shift: TShiftState);
  1121. begin
  1122.   TCCFileMgrForm( Parent ).BitBtn10Click( Sender );
  1123. end;
  1124.  
  1125. { Returns True if the Left Button was pressed in the last mouse operation }
  1126. function TIOManager.WasLeftPressed : Boolean;
  1127. begin
  1128.   if ( mbLeft = WhichButton ) then WasLeftPressed := true else
  1129.    WasLeftPressed := false;
  1130. end;
  1131.  
  1132. { Returns true if the Right Button was pressed in the last mouse operation }
  1133. function TIOManager.WasRightPressed : Boolean;
  1134. begin
  1135.   if mbRight = WhichButton then WasRightPressed := true else
  1136.    WasRightPressed := false;
  1137. end;
  1138.  
  1139. { Returns true if the Middle Button was pressed in the last mouse operation }
  1140. function TIOManager.WasMiddlePressed : Boolean;
  1141. begin
  1142.   if mbMiddle = WhichButton then WasMiddlePressed := true else
  1143.    WasMiddlePressed := false;
  1144. end;
  1145.  
  1146. { Returns true if the ALT key was down during the last IO operation }
  1147. function TIOManager.WasALTPressed : Boolean;
  1148. begin
  1149.   if ssAlt in WhichState then WasALTPressed := true else
  1150.    WasALTPressed := false;
  1151. end;
  1152.  
  1153. { Returns true if either SHIFT key was down during the last IO operation }
  1154. function TIOManager.WasSHIFTPressed : Boolean;
  1155. begin
  1156.   if ssShift in WhichState then WasSHIFTPressed := true else
  1157.    WasSHIFTPressed := false;
  1158. end;
  1159.  
  1160. { Returns true if the Control Key was down during the last IO operation }
  1161. function TIOManager.WasCTRLPressed : Boolean;
  1162. begin
  1163.   if ssCtrl in WhichState then WasCTRLPressed := true else
  1164.    WasCTRLPressed := false;
  1165. end;
  1166.  
  1167.  
  1168. { This procedure does a fully error-trapped change directory }
  1169. procedure TFileWorkBench.ChangeTheDirectory( NewPath : String );
  1170. var CurrentDirectory : String;
  1171. begin
  1172.   if NewPath = '..' then
  1173.   begin { Back up one level }
  1174.     {$I+}
  1175.     try
  1176.       { Find the current directory }
  1177.       GetDir( 0 , CurrentDirectory );
  1178.       { Use EFP to move up one level }
  1179.       CurrentDirectory := ExtractFilePath( CurrentDirectory );
  1180.       { Strip trailing \ if not root }
  1181.       CurrentDirectory := StripNonRootTrailingBackSlash( CurrentDirectory );
  1182.       { Try the change to the New drive }
  1183.       ChDir( CurrentDirectory );
  1184.     except
  1185.       { if any exception occurs instantiate exception and show }
  1186.       On E:EInOutError do
  1187.       begin
  1188.         { Call custom error display/lookup procedure }
  1189.         HandleIOException( EOC_CHANGEDIR , CurrentDirectory ,
  1190.          E.Message , E.ErrorCode );
  1191.       end;
  1192.     end;
  1193.   end
  1194.   else
  1195.   begin { Change to explicit path }
  1196.     {$I+}
  1197.     try
  1198.       { Get target directory path }
  1199.       CurrentDirectory := NewPath;
  1200.       { Strip trailing \ if not root }
  1201.       CurrentDirectory := StripNonRootTrailingBackSlash( CurrentDirectory );
  1202.       { Try the change to the New drive }
  1203.       ChDir( CurrentDirectory );
  1204.     except
  1205.       { if any exception occurs instantiate exception and show }
  1206.       On E:EInOutError do
  1207.       begin
  1208.         { Call custom error display/lookup procedure }
  1209.         HandleIOException( EOC_CHANGEDIR , CurrentDirectory ,
  1210.          E.Message , E.ErrorCode );
  1211.       end;
  1212.     end;
  1213.   end;
  1214. end;
  1215.  
  1216. { This procedure does a fully error-trapped change directory }
  1217. procedure TFileWorkBench.ChangeTheDriveAndDirectory( NewDrive : Integer );
  1218. var CurrentDirectory : String;
  1219. begin
  1220.   {$I+}
  1221.   try
  1222.     { Find the working directory on New drive }
  1223.     GetDir( NewDrive , CurrentDirectory );
  1224.     { Try the change to the New drive }
  1225.     ChDir( CurrentDirectory );
  1226.   except
  1227.     { if any exception occurs instantiate exception and show }
  1228.     On E:EInOutError do
  1229.     begin
  1230.       { Call custom error display/lookup procedure }
  1231.       HandleIOException( EOC_CHANGEDIR , CurrentDirectory ,
  1232.        E.Message , E.ErrorCode );
  1233.     end;
  1234.   end;
  1235. end;
  1236.  
  1237. { This procedure copies a single file with error trapping }
  1238. procedure TFileWorkBench.CopyTheFile( OldPath , NewPath : String );
  1239. var AResult : Boolean; { Internal data flag }
  1240. begin
  1241.   { If Copyfile returns false an error occurred }
  1242.   AResult := CopyFile( OldPath , NewPath +
  1243.    ExtractFileName( OldPath ));
  1244.   { Display meaningful error message }
  1245.   if not AResult then HandleDOSError( GlobalErrorType , OldPath, GlobalError );
  1246. end;
  1247.  
  1248. { This procedure moves a file by copying and delete it }
  1249. procedure TFileWorkBench.MoveTheFile( OldPath , NewPath : String );
  1250. var AResult : Boolean; { Internal data flag }
  1251.     TheFile : File;    { Use to get errors  }
  1252. begin
  1253.   { If Copyfile returns false an error occurred }
  1254.   AResult := CopyFile( OldPath , NewPath +
  1255.     ExtractFileName( OldPath ));
  1256.   { Display meaningful error message }
  1257.   if not AResult then HandleDOSError( GlobalErrorType ,
  1258.     OldPath , GlobalError );
  1259.   { After valid copying, delete source file }
  1260.   {$I+}
  1261.   if AResult then try
  1262.     { Use this trick to get valid exception handling }
  1263.     AssignFile( TheFile , OldPath );
  1264.     { Use erase because Deletefile doesn't give exceptions! }
  1265.     Erase( TheFile );
  1266.   except
  1267.     { if any exception occurs instantiate exception and show }
  1268.     On E:EInOutError do
  1269.     begin
  1270.       { Call custom error display/lookup procedure }
  1271.       HandleIOException( EOC_DELETEFILE , OldPath ,
  1272.        E.Message , E.ErrorCode );
  1273.     end;
  1274.   end;
  1275. end;
  1276.  
  1277. { This procedure safely deletes a single file }
  1278. procedure TFileWorkBench.DeleteTheFile( ThePath : String );
  1279. var TheFile : File; { Internal file handle }
  1280. begin
  1281.   {$I+}
  1282.   try
  1283.     { Use this trick to get valid exception handling }
  1284.     AssignFile( TheFile , ThePath );
  1285.     { Use erase because Deletefile doesn't give exceptions! }
  1286.     Erase( TheFile );
  1287.   except
  1288.     { if any exception occurs instantiate exception and show }
  1289.     On E:EInOutError do
  1290.     begin
  1291.       { Call custom error display/lookup procedure }
  1292.       HandleIOException( EOC_DELETEFILE , ThePath ,
  1293.        E.Message , E.ErrorCode );
  1294.     end;
  1295.   end;
  1296. end;
  1297.  
  1298. { This procedure renames a file with full error trapping }
  1299. procedure TFileWorkBench.RenameTheFile( OldPath , NewName : String );
  1300. var TheFile : File; { Internal file handle }
  1301. begin
  1302.   {$I+}
  1303.   try
  1304.     { Use this trick to get valid exception handling }
  1305.     AssignFile( TheFile , OldPath );
  1306.     { Use this because RenameFile doesn't give exceptions! }
  1307.     Rename( TheFile , NewName );
  1308.   except
  1309.     { if any exception occurs instantiate exception and show }
  1310.     On E:EInOutError do
  1311.     begin
  1312.       { Call custom error display/lookup procedure }
  1313.       HandleIOException( EOC_RENAMEFILE , OldPath  ,
  1314.        E.Message , E.ErrorCode );
  1315.     end;
  1316.   end;
  1317. end;
  1318.  
  1319. { This procedure creates a New directory with full error trapping }
  1320. procedure TFileWorkBench.CreateNewDirectory( NewPath : String );
  1321. begin
  1322.   {$I+}
  1323.   try
  1324.     Mkdir( NewPath );
  1325.   except
  1326.     { if any exception occurs instantiate exception and show }
  1327.     On E:EInOutError do
  1328.     begin
  1329.       { Call custom error display/lookup procedure }
  1330.       HandleIOException( EOC_MAKEDIR , NewPath  ,
  1331.        E.Message , E.ErrorCode );
  1332.     end;
  1333.   end;
  1334. end;
  1335.  
  1336. { This procedure remove a directory with full error trapping }
  1337. procedure TFileWorkBench.RemoveDirectory( ThePath : String );
  1338. begin
  1339.   {$I+}
  1340.   try
  1341.     Rmdir( ThePath );
  1342.   except
  1343.     { if any exception occurs instantiate exception and show }
  1344.     On E:EInOutError do
  1345.     begin
  1346.       { Call custom error display/lookup procedure }
  1347.       HandleIOException( EOC_DELETEDIR , ThePath  ,
  1348.        E.Message , E.ErrorCode );
  1349.     end;
  1350.   end;
  1351. end;
  1352.  
  1353. { Use this to set the attributes of a file with error trapping }
  1354. procedure TFileWorkBench.SetFileAttributes( TheFile  : String;
  1355.            TheAttributes : Integer );
  1356. var TheResult : Integer; { Holds error code if any }
  1357. begin
  1358.   { Attempt to set the attributes }
  1359.   TheResult := FileSetAttr( TheFile , TheAttributes );
  1360.   { if negative number error, so signal }
  1361.   if TheResult < 0 then
  1362.    HandleDOSError( EOC_SETATTR , TheFile , -TheResult );
  1363. end;
  1364.  
  1365. { This procedure recursively copies a directory to a New path }
  1366. procedure TFileWorkBench.RecursivelyCopyDirectory( OldPath , NewPath : String );
  1367. var TheDir : String; { Holds source directory }
  1368. begin
  1369.   { Get the source directory to copy }
  1370.   TheDir := ExtractFileName( OldPath );
  1371.   { Force a backslash to the Newpath variable }
  1372.   NewPath := ForceTrailingBackSlash( NewPath );
  1373.   { Add the source directory to the target path }
  1374.   NewPath := NewPath + TheDir;
  1375.   { Create a New directory with the New name }
  1376.   CreateNewDirectory( NewPath );
  1377.   { Force a backslash for compatibility }
  1378.   NewPath := FOrcetrailingBackSlash( NewPath );
  1379.   { Do the recursive call }
  1380.   HandleRecursiveAction( OldPath , NewPath , FAC_COPY );
  1381. end;
  1382.  
  1383. { This procedure recursively moves a directory tree }
  1384. procedure TFileWorkBench.RecursivelyMoveDirectory( OldPath , NewPath : String );
  1385. var TheDir    : String; { Holds source directory  }
  1386.     SavedPath : String; { Holds saved dir to kill }
  1387. begin
  1388.   { Get the source directory to move }
  1389.   TheDir := ExtractFileName( OldPath );
  1390.   { Force a backslash to the Newpath variable }
  1391.   NewPath := ForceTrailingBackSlash( NewPath );
  1392.   { Save the starting path just in case }
  1393.   SavedPath := OldPath;
  1394.   { Add the source directory to the target path }
  1395.   NewPath := NewPath + TheDir;
  1396.   { Create a New directory with the New name }
  1397.   CreateNewDirectory( NewPath );
  1398.   { Force a backslash for compatibility }
  1399.   NewPath := FOrcetrailingBackSlash( NewPath );
  1400.   { Do the recursive call }
  1401.   HandleRecursiveAction( OldPath , NewPath , FAC_MOVE );
  1402.   { Remove the source directory }
  1403.   RemoveDirectory( SavedPath );
  1404. end;
  1405.  
  1406. { This procedure handles recursively deleting an entire directory tree }
  1407. procedure TFileWorkBench.RecursivelyDeleteDirectory( ThePath : String );
  1408. begin
  1409.   HandleRecursiveAction( ThePath , '' , FAC_DELETE );
  1410. end;
  1411.  
  1412.  
  1413. { This is the generic routine to copy, move, and delete whole directory trees }
  1414. procedure TFileWorkBench.HandleRecursiveAction( StartingPath , NewPath : String;
  1415.            ActionCode : Integer );
  1416. { VITAL!!! These variables MUST be local for recursrion to work! }
  1417. var
  1418.     Finished        : Boolean;         { Loop flag              }
  1419.     TheSR           : TSearchRec;      { Searchrecord for FF/FN }
  1420.     TheResult       : Integer;         { return variable        }
  1421.     TargetPath ,
  1422.     FileMask   ,
  1423.     TheWorkingDirectory ,
  1424.     TheStoredWorkingDirectory ,
  1425.     ModifiedDirectory  : String;       { path for FF/FN         }
  1426.     TheFIP          : TFileIconPanel;  { generic FIP holder     }
  1427.     ButtonColor   ,                    { main panel color       }
  1428.     ButtonHLColor ,                    { bright panel color     }
  1429.     ButtonSColor  ,                    { dark panel color       }
  1430.     Textcolor       : TColor;          { label text color       }
  1431.     TheFile         : File;
  1432.  
  1433. begin
  1434.   { Set up the initial variables }
  1435.   Finished := false;
  1436.   TheWorkingDirectory := StartingPath;
  1437.   TheStoredWorkingDirectory := TheWorkingDirectory;
  1438.   TheWorkingDirectory := TheWorkingDirectory + '\*.*';
  1439.   TargetPath := ExtractFilePath( TheWorkingDirectory );
  1440.   { Make the call to FindFirst set to get any file }
  1441.   TheResult := FindFirst( TheWorkingDirectory , faAnyFile , TheSR );
  1442.   { loop through all files in the directory and delete them }
  1443.   while not Finished do
  1444.   begin
  1445.     { Make call to FindNext, using only SearchRecord from FindFirst }
  1446.     TheResult := FindNext( TheSR );
  1447.     { A -1 result means no more files so exit }
  1448.     if TheResult <> 0 then finished := true else
  1449.     begin
  1450.       if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory )
  1451.        <> faDirectory ) then
  1452.       begin { A File }
  1453.         case ActionCode of
  1454.           FAC_COPY :
  1455.               begin
  1456.                 CopyTheFile( TargetPath + TheSR.Name , NewPath );
  1457.               end;
  1458.           FAC_MOVE :
  1459.               begin
  1460.                 MoveTheFile( TargetPath + TheSR.Name , NewPath );
  1461.               end;
  1462.           FAC_DELETE :
  1463.               begin { Delete }
  1464.                 if MessageDlg( 'Delete file ' + TargetPath + TheSR.Name + '?',
  1465.                    mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  1466.                     DeleteTheFile( TargetPath + TheSR.Name );
  1467.               end;
  1468.         end;
  1469.       end;
  1470.     end;
  1471.   end;
  1472.   { Set up the variables to do recursive calls on all directories}
  1473.   Finished := false;
  1474.   ModifiedDirectory := TheStoredWorkingdirectory + '\*.*';
  1475.   { Make the call to FindFirst set to get any file, ignore result }
  1476.   TheResult := FindFirst( ModifiedDirectory , faDirectory , TheSR );
  1477.   while not Finished do
  1478.   begin
  1479.     { Make call to FindNext, using only SearchRecord from FindFirst }
  1480.     TheResult := FindNext( TheSR );
  1481.     { A -1 result means no more files so exit }
  1482.     if TheResult <> 0 then
  1483.       finished := true
  1484.     else
  1485.     begin
  1486.       if TheSR.Name <> '..' then { Ignore backup in this case }
  1487.       begin
  1488.         if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory )
  1489.          = faDirectory ) then
  1490.         begin
  1491.           { Send in the New directory name }
  1492.           ModifiedDirectory := TheStoredWorkingDirectory  + '\' +
  1493.            TheSR.Name;
  1494.           { Reproduce directory structure for recursion in copy/move }
  1495.           NewPath := NewPath + TheSR.Name;
  1496.           case ActionCode of
  1497.             FAC_COPY , FAC_MOVE :
  1498.                begin { Create ahead for move and copy }
  1499.                  { Make the New directory for moving and copying }
  1500.                  CreateNewDirectory( NewPath );
  1501.                  { Force a backslash for compatibility }
  1502.                  NewPath := ForceTrailingBackSlash( NewPath );
  1503.                end;
  1504.             FAC_DELETE :
  1505.                begin  { No prior action needed for Delete }
  1506.                end;
  1507.           end;
  1508.           { Do the recursive call }
  1509.           HandleRecursiveAction( ModifiedDirectory , NewPath , ActionCode );
  1510.           case ActionCode of
  1511.             FAC_COPY :
  1512.                begin { no action for copy }
  1513.                end;
  1514.             FAC_MOVE , FAC_DELETE :
  1515.                begin  { Delete }
  1516.                  { Get a confirmation }
  1517.                  if MessageDlg( 'Remove Directory ' + TargetPath + TheSR.Name
  1518.                   + '?', mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  1519.                    RemoveDirectory( TargetPath + TheSR.Name );
  1520.                end;
  1521.           end;
  1522.         end;
  1523.       end;
  1524.     end;
  1525.   end;
  1526. end;
  1527.  
  1528. { This is a generic copy routine taken from Delphi sample code }
  1529. { This function calls the sample Copy code and handles errors }
  1530. function TFileWorkBench.CopyFile( TargetPath ,
  1531.           DestinationPath : String ) : Boolean;
  1532. begin
  1533.   { Set global error value to no error }
  1534.   GlobalError := 0;
  1535.   { Call the sample procedure to do the copy }
  1536.   FMXUCopyFile( TargetPath, DestinationPath , GlobalErrorType , GlobalError );
  1537.   { If no error return true else return false }
  1538.   if GlobalError < 0 then CopyFile := false else
  1539.    CopyFile := true;
  1540. end;
  1541.  
  1542. { This procedure handles displaying a user-friendly Dialog box with a }
  1543. { Message for Delphi IO exception errors.                             }
  1544. procedure TFileWorkBench.HandleIOException( TheOpCode : Integer;
  1545.            ThePath : String; TheMessage : String; TheCode : Integer );
  1546. var ErrorMessageString : String;  { Holds internal data }
  1547.     OperationString    : String;  { Holds internal data }
  1548. begin
  1549.   { clear to check for unrecognized code }
  1550.   ErrorMessageString := '';
  1551.   { Check against imported code }
  1552.   case TheCode of
  1553.     2    : ErrorMessageString := 'File not found';
  1554.     3    : ErrorMessageString := 'Path not found';
  1555.     4    : ErrorMessageString := 'Too many open files';
  1556.     5    : ErrorMessageString := 'File access denied';
  1557.     6    : ErrorMessageString := 'Invalid file handle';
  1558.     12    : ErrorMessageString := 'Invalid file access code';
  1559.     15    : ErrorMessageString := 'Invalid drive number';
  1560.     16  : ErrorMessageString := 'Cannot remove current directory';
  1561.     17    : ErrorMessageString := 'Cannot rename across drives';
  1562.     100    : ErrorMessageString := 'Disk read error';
  1563.     101    : ErrorMessageString := 'Disk write error';
  1564.     102    : ErrorMessageString := 'File not assigned';
  1565.     103    : ErrorMessageString := 'File not open';
  1566.     104    : ErrorMessageString := 'File not open for input';
  1567.     105    : ErrorMessageString := 'File not open for output';
  1568.   end;
  1569.   case TheOpCode of
  1570.     EOC_CHANGEDIR : OperationString := 'Unable to Change Directory due to ';
  1571.     EOC_SOURCECOPY : OperationString := 'Unable to Copy due to Source File ';
  1572.     EOC_DESTCOPY : OperationString := 'Unable to Copy due to Destination File ';
  1573.     EOC_DELETEFILE : OperationString := 'Unable to Delete File due to ';
  1574.     EOC_DELETEDIR : OperationString := 'Unable to Delete Directory due to ';
  1575.     EOC_RENAMEFILE : OperationString := 'Unable to Rename File due to ';
  1576.     EOC_MAKEDIR : OperationString := 'Unable to Create New Directory due to ';
  1577.     EOC_SETATTR : OperationString := 'Unable to Set File Attributes due to ';
  1578.   end;
  1579.   { If not recognized use message; not a DOS error; reset cursor for neatness }
  1580.   if ErrorMessageString = '' then
  1581.   begin
  1582.     Screen.Cursor := crDefault;
  1583.     MessageDlg( OperationString + ExtractFileName( ThePath ) + ' ' +
  1584.      TheMessage , mtError , [mbOK],0);
  1585.   end
  1586.   else
  1587.   begin
  1588.     { Recognized DOS exception, reset cursor for neatness }
  1589.     Screen.Cursor := crDefault;
  1590.     MessageDlg( OperationString + ExtractFileName( ThePath ) + ' ' +
  1591.      ErrorMessageString , mtError , [mbOK], 0 );
  1592.   end;
  1593. end;
  1594.  
  1595. { This procedure handles displaying a user-friendly Dialog box with a }
  1596. { Message for DOS error codes.                                        }
  1597. procedure TFileWorkBench.HandleDOSError( TheOpCode : Integer;
  1598.            ThePath : String;  TheCode : Integer );
  1599. var ErrorMessageString : String;  { internal message holder }
  1600.     OperationString : String;     { internal message holder }
  1601. begin
  1602.   { clear the message holder to check for unrecognized code }
  1603.   ErrorMessageString := '';
  1604.   { Negate the code back to normal number and check to set string }
  1605.   case -TheCode of
  1606.     2    : ErrorMessageString := 'File not found';
  1607.     3    : ErrorMessageString := 'Path not found';
  1608.     4    : ErrorMessageString := 'Too many open files';
  1609.     5    : ErrorMessageString := 'File access denied';
  1610.     6    : ErrorMessageString := 'Invalid file handle';
  1611.     12    : ErrorMessageString := 'Invalid file access code';
  1612.     15    : ErrorMessageString := 'Invalid drive number';
  1613.     16  : ErrorMessageString := 'Cannot remove current directory';
  1614.     17    : ErrorMessageString := 'Cannot rename across drives';
  1615.     100    : ErrorMessageString := 'Disk read error';
  1616.     101    : ErrorMessageString := 'Disk write error';
  1617.     102    : ErrorMessageString := 'File not assigned';
  1618.     103    : ErrorMessageString := 'File not open';
  1619.     104    : ErrorMessageString := 'File not open for input';
  1620.     105    : ErrorMessageString := 'File not open for output';
  1621.     157 : ErrormessageString := 'Could not open Source File';
  1622.     159 : ErrormessageString := 'Could not open Target File';
  1623.   end;
  1624.   case TheOpCode of
  1625.     EOC_CHANGEDIR : OperationString := 'Unable to Change Directory due to ';
  1626.     EOC_SOURCECOPY : OperationString := 'Unable to Copy due to Source File ';
  1627.     EOC_DESTCOPY : OperationString := 'Unable to Copy due to Destination File ';
  1628.     EOC_DELETEFILE : OperationString := 'Unable to Delete File due to ';
  1629.     EOC_DELETEDIR : OperationString := 'Unable to Delete Directory due to ';
  1630.     EOC_RENAMEFILE : OperationString := 'Unable to Rename File due to ';
  1631.     EOC_MAKEDIR : OperationString := 'Unable to Create New Directory due to ';
  1632.     EOC_SETATTR : OperationString := 'Unable to Set File Attributes due to ';
  1633.   end;
  1634.   { If the string is empty an unrecognized code was sent in }
  1635.   if ErrorMessageString = '' then
  1636.   begin
  1637.     { Sent up db based on source or target error; reset cursor for neatness }
  1638.     Screen.Cursor := crDefault;
  1639.     MessageDlg( OperationString + ExtractFileName( ThePath ) + ' Error Code: ' +
  1640.      IntToStr( TheCode ) , mtError , [mbOK],0);
  1641.   end
  1642.   else  { Code is recognized, use message from case statement }
  1643.   begin
  1644.     { Format the output for source or target error }
  1645.     Screen.Cursor := crDefault;
  1646.     MessageDlg( OperationString + ExtractFileName( ThePath ) + ' ' +
  1647.      ErrorMessageString , mtError , [mbOK], 0 );
  1648.   end;
  1649. end;
  1650.  
  1651. { This procedure sets the imported booleans to the file's attributes }
  1652. procedure TFileWorkBench.GetFileAttributes( TheFile : String; var IsDirectory ,
  1653.            IsArchive , IsVolumeID , IsHidden , IsReadOnly ,
  1654.             IsSysFile : Boolean );
  1655. var TheResult : Integer; { Traps for error code on VolumeID }
  1656. begin
  1657.   { Clear the imported flags for default }
  1658.   IsDirectory := false;
  1659.   IsArchive := false;
  1660.   IsVolumeID := false;
  1661.   IsHidden := False;
  1662.   IsReadOnly := false;
  1663.   IsSysFile := false;
  1664.   { Make the Dos call }
  1665.   TheResult := FileGetAttr( TheFile );
  1666.   if TheResult < 0 then
  1667.   begin
  1668.     { Volume ID returns -2 (?) }
  1669.     IsVolumeID := true;
  1670.     { It has no other properties }
  1671.     exit;
  1672.   end;
  1673.   { Use AND test to set all other properties }
  1674.   if (( TheResult and faDirectory ) = faDirectory ) then IsDirectory := true;
  1675.   if (( TheResult and faArchive ) = faArchive ) then IsArchive := true;
  1676.   if (( TheResult and faVolumeID ) = faVolumeID ) then IsVolumeID := true;
  1677.   if (( TheResult and faReadOnly ) = faReadOnly ) then IsReadOnly := true;
  1678.   if (( TheResult and faHidden ) = faHidden ) then IsHidden := true;
  1679.   if (( TheResult and faSysFile ) = faSysFile ) then IsSysFile := true;
  1680. end;
  1681.  
  1682. { This function makes sure a pathname has a trailing \ }
  1683. function TFileWorkBench.ForceTrailingBackSlash(
  1684.           const TheFileName : String ) : String;
  1685. var TempString : String;  { Used to hold function result }
  1686. begin
  1687.   { If no trailing \ add one (root will already have one.) }
  1688.   if TheFileName[ Length( TheFileName ) ] <> '\' then
  1689.    TempString := TheFileName + '\' else TempString := TheFileName;
  1690.   { Return modified or non-modified string }
  1691.   ForceTrailingBackslash := TempString;
  1692. end;
  1693.  
  1694. { This function makes sure a non-root dir has no trailing \ }
  1695. function TFileWorkBench.StripNonRootTrailingBackSlash(
  1696.           const TheFileName : String ) : String;
  1697. var TempString : String ; { Used to hold function result }
  1698. begin
  1699.   { Default is no change }
  1700.   TempString := TheFileName;
  1701.   { If not root then }
  1702.   if Length( TheFileName ) > 3 then
  1703.   begin
  1704.     { If has a trailing backslash remove it }
  1705.     if TheFileName[ Length( TheFileName )] = '\' then
  1706.     begin
  1707.       TempString := Copy( TheFileName , 1 ,
  1708.        Length( TheFileName ) - 1 );
  1709.     end;
  1710.   end;
  1711.   { Export the final result }
  1712.   StripNonRootTrailingBackSlash := TempString;
  1713. end;
  1714.  
  1715. { This gets the next selected listbox item }
  1716. function TIconFileListBox.GetNextSelection( SourceDirectory : String;
  1717.           var CurrentItem : Integer ): String;
  1718. var TheResult : String;  { Internal storage }
  1719.     finished  : boolean; { Loop flag        }
  1720. begin
  1721.   { If out of items to check signal and exit }
  1722.   if CurrentItem > Items.Count then TheResult := '' else
  1723.   begin
  1724.     { Otherwise scan from current position till match or end }
  1725.     finished := false;
  1726.     while not finished do
  1727.     begin
  1728.       { Check against selected property }
  1729.       if Selected[ CurrentItem - 1 ] then
  1730.       begin
  1731.         { If selected then return it and abort loop }
  1732.         TheResult := SourceDirectory + Items[ CurrentItem - 1 ];
  1733.         finished := true;
  1734.         { Increment current position }
  1735.         CurrentItem := CurrentItem + 1;
  1736.      end
  1737.       else
  1738.       begin
  1739.         { Increment current position }
  1740.         CurrentItem := CurrentItem + 1;
  1741.         { Otherwise check for end of data and abort if out of entries }
  1742.         if CurrentItem > Items.Count then
  1743.         begin
  1744.           TheResult := '';
  1745.           finished := true;
  1746.         end;
  1747.       end;
  1748.     end;
  1749.   end;
  1750.   { Return stored result }
  1751.   GetNextSelection := TheResult;
  1752. end;
  1753.  
  1754. { Modified from VCL Source Copyright 1995 }
  1755. { Borland International, Inc.             }
  1756. { Use this to override display with icons }
  1757. procedure TIconFileListBox.ReadFileNames;
  1758. var
  1759.   AttrIndex   : TFileAttr;
  1760.   i           : Integer;
  1761.   FileExt     : string;
  1762.   MaskPtr     : PChar;
  1763.   Ptr         : PChar;
  1764.   AttrWord    : Word;
  1765.   TempPicture : TPicture;
  1766.   TempBmp     : TBitmap;
  1767.   TempIcon    : TIcon;
  1768. const
  1769.   Attributes: array[TFileAttr] of Word =
  1770.   ( DDL_READONLY , DDL_HIDDEN , DDL_SYSTEM , $0008 , DDL_DIRECTORY ,
  1771.     DDL_ARCHIVE  , DDL_EXCLUSIVE );
  1772. begin
  1773.   { if no handle allocated yet, this call will force         }
  1774.   { one to be allocated incorrectly (i.e. at the wrong time. }
  1775.   { In due time, one will be allocated appropriately.        }
  1776.   AttrWord := DDL_READWRITE;
  1777.   if HandleAllocated then
  1778.   begin
  1779.     { Set attribute flags based on values in FileType }
  1780.     for AttrIndex := ftReadOnly to ftArchive do
  1781.      if AttrIndex in FileType then
  1782.       AttrWord := AttrWord or Attributes[ AttrIndex ];
  1783.  
  1784.     { Use Exclusive bit to exclude normal files }
  1785.     if not ( ftNormal in FileType ) then
  1786.       AttrWord := AttrWord or DDL_EXCLUSIVE;
  1787.  
  1788.     ChDir( FDirectory ); { go to the directory we want }
  1789.     Clear;               { clear the list }
  1790.  
  1791.     GetMem( MaskPtr , 256 );
  1792.     StrPCopy( MaskPtr , FMask );
  1793.     while MaskPtr <> nil do
  1794.     begin
  1795.       Ptr := StrScan ( MaskPtr , ';' );
  1796.       if Ptr <> nil then  Ptr^ := #0;
  1797.       { build the list }
  1798.       SendMessage( Handle , LB_DIR , AttrWord , Longint( MaskPtr ));
  1799.       if Ptr <> nil then
  1800.       begin
  1801.         Ptr^ := ';';
  1802.         Inc ( Ptr );
  1803.       end;
  1804.       MaskPtr := Ptr;
  1805.     end;
  1806.     FreeMem( MaskPtr , 256 );
  1807.     { Now add the bitmaps }
  1808.     {---------------------------- begin custom code --------------------------}
  1809.     { Create the TPicture for exchange purposes }
  1810.     TempPicture := TPicture.Create;
  1811.     { Set it to icon widths }
  1812.     TempPicture.Bitmap.Width := 32;
  1813.     TempPicture.Bitmap.Height := 32;
  1814.     { Run down the list }
  1815.     for i := 0 to Items.Count - 1 do
  1816.     begin
  1817.       { Create a New temporary icon }
  1818.       TempIcon := TIcon.Create;
  1819.       { Call the custom DRWS routine to get icon for a file }
  1820.       GetIconForFile( Items[ i ] , TempIcon );
  1821.       { Put the icon on the bitmap for the picture via draw }
  1822.       { Note 1 , 1 due to bug in Draw?                      }
  1823.       TempPicture.Bitmap.Canvas.Draw( 1 , 1 , TempIcon );
  1824.       { Create a temporary bitmap }
  1825.       TempBmp := TBitmap.Create;
  1826.       { Set its width to those of the previous object's bitmaps }
  1827.       TempBmp.Width := 16;
  1828.       TempBmp.Height := 15;
  1829.       { Resize the icon's bitmap to the smaller size with stretchdraw }
  1830.       TempBmp.Canvas.StretchDraw( Rect( 1 , 1 , 15 , 14 ) ,
  1831.        TempPicture.Bitmap );
  1832.       { Set the Objects list to the bitmap }
  1833.       Items.Objects[ i ] := TempBmp;
  1834.       { Free the icon each iteration; don't free the TempBmp as list does }
  1835.       TempIcon.Free;
  1836.     end;
  1837.     { Free the TPicture exchange element }
  1838.     TempPicture.Free;
  1839.     {------------------------ end custom code --------------------------------}
  1840.     Change;
  1841.   end;
  1842. end;
  1843.  
  1844. { Use this to respond to dbl-clicking FLB filename }
  1845. procedure TIconFileListBox.TheDblClick(Sender: TObject);
  1846. begin
  1847.   { Call shellexec as a wrapper around ShellExecute API call }
  1848.   { False indicates failure, signal error                    }
  1849.   if not ShellExec( ExpandFileName( Items[ ItemIndex ] ), '' , '', false ,
  1850.    SW_SHOWNORMAL , false ) then MessageDlg('Could not Shell out to ' +
  1851.     Items[ ItemIndex ] , mtError, [mbOK], 0);
  1852. end;
  1853.  
  1854. { Create method for FIP                                }
  1855. constructor TIconFileListBox.Create( AOwner : TComponent );
  1856. begin
  1857.   { call inherited -- VITAL! }
  1858.   inherited Create( AOwner );
  1859.   { set the mouse method }
  1860.   OnDblClick := TheDblClick;
  1861. end;
  1862.  
  1863. { Create method for FIP                                }
  1864. constructor TFileIconPanel.Create( AOwner : TComponent );
  1865. begin
  1866.   { call inherited -- VITAL! }
  1867.   inherited Create( AOwner );
  1868.   { create icon and label components, making self owner/displayer }
  1869.   FTheIcon := TIcon.Create;
  1870.   FTheLabel := TLabel.Create( Self );
  1871.   FThelabel.Parent := Self;
  1872.   { Set own and labels mouse methods to stored methods }
  1873.   OnMouseUp := TheMouseUp;
  1874.   OnMouseDown := TheMouseDown;
  1875.   OnMouseMove := TheMouseMove;
  1876.   OnDragOver := TheDragOver;
  1877.   OnDragDrop := TheDragDrop;
  1878.   { Set alignment and autosize properties of the label }
  1879.   FTheLabel.Autosize := false;
  1880.   FTheLabel.Alignment := taCenter;
  1881.   { Set selected to false }
  1882.   Selected := false;
  1883. end;
  1884.  
  1885. procedure TFileIconPanel.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  1886. var CurrentDirectory : String;    { Use to store dirs }
  1887.     TheDrive         : String;    { Get drive letter  }
  1888.     WhichDrive       : Integer;   { Get drive number  }
  1889.     ErrorCheck       : Integer;
  1890.     TheFWB           : TFileWorkBench;
  1891. begin
  1892.   { Create FileWorkBench for later use }
  1893.   TheFWB := TFileWorkBench.Create( Self );
  1894.   { Check for label or FIP sender }
  1895.   if FTheLabel.Caption = '..' then
  1896.   begin { deal with backup request }
  1897.     { Change to New directory }
  1898.     TheFWB.ChangeTheDirectory( '..' );
  1899.     { Call special method due to SendMessage problem! }
  1900.     TFileIconPanelScrollBox( Parent ).Update;
  1901.   end
  1902.   else
  1903.   begin
  1904.     { Check for DRIVE id in name }
  1905.     if Pos( 'DRIVE' , FTheName ) <> 0 then
  1906.     begin { Double Click on a Drive Icon }
  1907.       { Pull out the letter from name }
  1908.       TheDrive := Copy( FtheName , 7 , 1 );
  1909.       { Convert it to a number }
  1910.       WhichDrive := ( Ord( TheDrive[ 1 ] ) - Ord( 'A' )) + 1;
  1911.       TheFWB.ChangeTheDriveAndDirectory( WhichDrive );
  1912.       { Call special method due to SendMessage problem! }
  1913.       TFileIconPanelScrollBox( Parent ).Update;
  1914.     end
  1915.     else
  1916.     begin { Double click on a dir/file icon }
  1917.       if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
  1918.       begin { A directory, change to it }
  1919.         { Since full path in name, simply change to it! }
  1920.         TheFWB.ChangeTheDirectory( FTheName );
  1921.         { Call special method due to SendMessage problem! }
  1922.         TFileIconPanelScrollBox( Parent ).Update;
  1923.       end
  1924.       else
  1925.       begin { A file; attempt to shellexecute it }
  1926.         { Call shellexec as a wrapper around ShellExecute API call }
  1927.         { False indicates failure, signal error                    }
  1928.         if not ShellExec( FTheName , '' , '', false , SW_SHOWNORMAL , false )
  1929.          then MessageDlg('Could not Shell out to ' + FTheName , mtError,
  1930.           [mbOK], 0);
  1931.       end;
  1932.     end;
  1933.   end;
  1934.   TheFWB.Free; { This prevents resource leak }
  1935. end;
  1936.  
  1937. { Initialization method for FIP                                         }
  1938. procedure TFileIconPanel.Initialize( PanelX              ,
  1939.                                      PanelY              ,
  1940.                                      PanelWidth          ,
  1941.                                      PanelHeight         ,
  1942.                                      PanelBevelWidth     ,
  1943.                                      LabelFontSize         : Integer;
  1944.                                      PanelColor          ,
  1945.                                      PanelHighlightColor ,
  1946.                                      PanelShadowColor    ,
  1947.                                      LabelTextColor        : TColor;
  1948.                                      TheFilename         ,
  1949.                                      LabelFontName         : String;
  1950.                                      LabelFontStyle        : TFontStyles;
  1951.                                      ExtraData             : Integer );
  1952.  
  1953. var TheLabelHeight ,             { Holder for label pixel height }
  1954.     TheLabelWidth    : Integer;  { Holder for label pixel width  }
  1955.     TheOtherPChar    : PChar;    { Windows ASCIIZ string         }
  1956. begin
  1957.   { Set the basic properties based on imported parameters }
  1958.   Left := PanelX;
  1959.   Top := PanelY;
  1960.   Width := PanelWidth;
  1961.   Height := PanelHeight;
  1962.   Color := PanelColor;
  1963.   BevelWidth := PanelBevelWidth;
  1964.   FHighlightColor := PanelHighlightColor;
  1965.   FShadowColor := PanelShadowColor;
  1966.   FTheName := TheFilename;
  1967.   { If the ExtraData field is non-0 then a drive is being sent in }
  1968.   if ExtraData <> 0 then
  1969.   begin
  1970.     { Use the data field value to determine which icon to get from RES file }
  1971.     case ExtraData of
  1972.       1 : begin
  1973.             GetMem( TheOtherPChar , 255 );
  1974.             StrPCopy( TheOtherPChar , 'FLOPPY35' );
  1975.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  1976.             FreeMem( TheOtherPChar , 255 );
  1977.           end;
  1978.       2 : begin
  1979.             GetMem( TheOtherPChar , 255 );
  1980.             StrPCopy( TheOtherPChar , 'FIXEDHD' );
  1981.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  1982.             FreeMem( TheOtherPChar , 255 );
  1983.           end;
  1984.       3 : begin
  1985.             GetMem( TheOtherPChar , 255 );
  1986.             StrPCopy( TheOtherPChar , 'NETWORKHD' );
  1987.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  1988.             FreeMem( TheOtherPChar , 255 );
  1989.           end;
  1990.       4 : begin
  1991.             GetMem( TheOtherPChar , 255 );
  1992.             StrPCopy( TheOtherPChar , 'CDROM' );
  1993.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  1994.             FreeMem( TheOtherPChar , 255 );
  1995.           end;
  1996.       5 : begin
  1997.             GetMem( TheOtherPChar , 255 );
  1998.             StrPCopy( TheOtherPChar , 'RAM' );
  1999.             FTheIcon.Handle := LoadIcon( hInstance , TheOtherPChar );
  2000.             FreeMem( TheOtherPChar , 255 );
  2001.           end;
  2002.     end;
  2003.     { The FileNme property is already set up for the caption; use directly }
  2004.     FTheLabel.Caption := TheFilename;
  2005.     { Set up the hint for later use (make sure to set ShowHint) }
  2006.     Hint := 'Change to ' + TheFileName;
  2007.     ShowHint := true;
  2008.     { Set up all imported label properties and center it for drawing }
  2009.     with FTheLabel do
  2010.     begin
  2011.       Font.Name := LabelFontName;
  2012.       Font.Size := LabelFontSize;
  2013.       Font.Style := LabelFontStyle;
  2014.       Font.Color := LabelTextColor;
  2015.       Canvas.Brush.Color := PanelColor;
  2016.       Canvas.Font := Font;
  2017.       TheLabelHeight := Canvas.Textheight( Caption ) + 4;
  2018.       TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
  2019.       Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
  2020.       Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
  2021.       Top := Top + Round( Self.Height * 0.75 );
  2022.       Height := TheLabelHeight;
  2023.       Width := TheLabelWidth;
  2024.     end;
  2025.   end
  2026.   else
  2027.   begin
  2028.     { A file or directory has been sent in; use GetIconForFile to obtain an }
  2029.     { icon either from the file, its owner, or a RES file default.          }
  2030.     GetIconForFile( FTheName , FTheIcon );
  2031.     { Check for the Backup caption and set it specially }
  2032.     if ExtractfileName( FThename ) = '..' then
  2033.     begin
  2034.       FTheLabel.Caption := '..';
  2035.       Hint := 'Up One Level';
  2036.     end
  2037.     else
  2038.     begin
  2039.       { Otherwise just get the filename for the label caption }
  2040.       { And the full path for the hint (used later.)          }
  2041.       FTheLabel.caption := ExtractFileName( UpperCase( FTheName ));
  2042.       Hint := FTheName;
  2043.     end;
  2044.     { Activate showhint so hints are seen }
  2045.     ShowHint := true;
  2046.     { Set label properties with imported values and center for display }
  2047.     with FTheLabel do
  2048.     begin
  2049.       Font.Name := LabelFontName;
  2050.       Font.Size := LabelFontSize;
  2051.       Font.Style := LabelFontStyle;
  2052.       Font.Color := LabelTextColor;
  2053.       Canvas.Brush.Color := PanelColor;
  2054.       Canvas.Font := Font;
  2055.       TheLabelHeight := Canvas.Textheight( Caption ) + 4;
  2056.       TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
  2057.       Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
  2058.       Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
  2059.       Top := Top + Round( Self.Height * 0.75 );
  2060.       Height := TheLabelHeight;
  2061.       Width := TheLabelWidth;
  2062.     end;
  2063.   end;
  2064. end;
  2065.  
  2066. { Destroy method for FIP }
  2067. destructor TFileIconPanel.Destroy;
  2068. begin
  2069.   { free component resources }
  2070.   FTheIcon.Free;
  2071.   FTheLabel.Free;
  2072.   { call inherited -- VITAL! }
  2073.   inherited Destroy;
  2074. end;
  2075.  
  2076. { Mousedown method for FIP; used to allow dragging }
  2077. procedure TFileIconPanel.TheMouseDown(Sender: TObject;
  2078.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  2079. var ThePoint , TheOtherPoint : TPoint;
  2080. begin
  2081.   { Begin a conditional drag operation (false allows timer) }
  2082.   TheIOManager.WhichButton := Button;
  2083.   TheIOManager.WhichState := Shift;
  2084.   { Currently ignore drive clicks }
  2085.   if Pos( 'DRIVE' , FTheName ) > 0 then exit;
  2086.   if (( Button = mbRight ) and ( ssShift in Shift )) then
  2087.   begin
  2088.     TheTempBitmap := TBitmap.Create;
  2089.     TheTempBitmap.Width := Self.Width;
  2090.     TheTempBitmap.Height := Self.Height;
  2091.     TheTempBitmap.Canvas.Copyrect( Rect( 0 , 0 , Self.Width , Self.Height ) ,
  2092.      Self.Canvas , Rect( 0 , 0 , Self.Width , Self.Height ));
  2093.     TheMouseManager.InitializeBitmap( TheTempBitmap );
  2094.     ThePoint.X := X;
  2095.     ThePoint.Y := Y;
  2096.     TheOtherPoint := ClientToScreen( ThePoint );
  2097.     TheMouseManager.StartBitmapCursor( TheOtherPoint.X , TheOtherPoint.Y );
  2098.     BitmapDragging := true;
  2099.     GlobalSource := Self;
  2100.     exit;
  2101.   end;
  2102.   if Button = mbRight then
  2103.   begin
  2104.     TheMouseManager.InitializeIcon( FTheIcon );
  2105.     ThePoint.X := X;
  2106.     ThePoint.Y := Y;
  2107.     TheOtherPoint := ClientToScreen( ThePoint );
  2108.     TheMouseManager.StartIconCursor( TheOtherPoint.X , TheOtherPoint.Y );
  2109.     IconDragging := true;
  2110.     GlobalSource := Self;
  2111.     exit;
  2112.   end;
  2113.   BeginDrag( false );
  2114.   { Flip status of bevels }
  2115.   if BevelOuter = bvRaised then BevelOuter := bvLowered else
  2116.    BevelOuter := bvRaised;
  2117.   { Flip selected variable }
  2118.   Selected := not Selected;
  2119.   { Set redisplay }
  2120. end;
  2121.  
  2122. procedure TFileIconPanel.TheMouseMove(Sender: TObject; Shift: TShiftState;
  2123.   X, Y: Integer);
  2124. var ThePoint, TheOtherPoint : TPoint;
  2125. begin
  2126.   if IconDragging then
  2127.   begin
  2128.     ThePoint.X := X;
  2129.     ThePoint.Y := Y;
  2130.     TheOtherPoint := ClientToScreen( ThePoint );
  2131.     TheMouseManager.MoveIconCursor( TheOtherPoint.X , TheOtherPoint.Y );
  2132.     exit;
  2133.   end;
  2134.   if BitmapDragging then
  2135.   begin
  2136.     ThePoint.X := X;
  2137.     ThePoint.Y := Y;
  2138.     TheOtherPoint := ClientToScreen( ThePoint );
  2139.     TheMouseManager.MoveBitmapCursor( TheOtherPoint.X , TheOtherPoint.Y );
  2140.     exit;
  2141.   end;
  2142. end;
  2143.  
  2144. { Mouseup Method for FIP; used to allow dragging }
  2145. procedure TFileIconPanel.TheMouseUp(Sender: TObject;
  2146.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  2147. begin
  2148.   if IconDragging then
  2149.   begin
  2150.     TheMouseManager.EndIconCursor( X , Y );
  2151.     IconDragging := false;
  2152.     if GlobalSource <> Self then
  2153.     begin { Right-drag onto a panel! }
  2154.       TheDragDrop( Sender , GlobalSource , X , Y );
  2155.     end;
  2156.     exit;
  2157.   end;
  2158.   if BitmapDragging then
  2159.   begin
  2160.     TheMouseManager.EndBitmapCursor( X , Y );
  2161.     BitmapDragging := false;
  2162.     if GlobalSource <> Self then
  2163.     begin { Right-drag onto a panel! }
  2164.       TheDragDrop( Sender , GlobalSource , X , Y );
  2165.     end;
  2166.     exit;
  2167.   end;
  2168.   { End a drag operation without dropping; if dragged OK }
  2169.   { already handled.                                     }
  2170.   {EndDrag( false );}
  2171.   { If the right button is clicked, perform magic! }
  2172.   { Redisplay on general principles }
  2173.   Invalidate;
  2174. end;
  2175.  
  2176. { Use this to generically OK DnD from FIPs }
  2177. procedure TFileIconPanel.TheDragOver(Sender, Source: TObject; X,
  2178.   Y: Integer; State: TDragState; var Accept: Boolean);
  2179. begin
  2180.   { Only accept from FileIconPanel components }
  2181.   if Source is TFileIconPanel then Accept := true else Accept := false;
  2182. end;
  2183.  
  2184. { Use this to accept Drag and Drop from other FIPs }
  2185. procedure TFileIconPanel.TheDragDrop(Sender, Source: TObject; X,
  2186.   Y: Integer);
  2187. var CurrentName ,                 { Holds work name}
  2188.     TheOldString : String;        { Holds Dir      }
  2189.     TargetDir    : String;        { target of op   }
  2190.     TheResult       : Integer;    { Modal res hold }
  2191.     SourceDirectory,
  2192.     TargetDirectory,
  2193.     CurrentDirectory : String;    { Use to store dirs }
  2194.     TheDrive         : String;    { Get drive letter  }
  2195.     WhichDrive       : Integer;   { Get drive number  }
  2196.     ErrorCheck       : Integer;
  2197.     TheFWB           : TFileWorkBench;
  2198.     ThePosition : Integer;
  2199.     Finished : Boolean;
  2200.     TheFIPSB : TFileIconPanelScrollBox;
  2201. begin
  2202.   { If drop target is .. then ignore }
  2203.   if FTheLabel.Caption = '..' then exit;
  2204.   { Likewise ignore Dnd from drive icons }
  2205.   if Pos( 'DRIVE' , TFileIconPanel( Source ).FtheName ) > 0 then exit;
  2206.   { Obtain the parent of the source FIP; may not be self }
  2207.   TheFIPSB := TFileIconPanelScrollBox( TFileIconPanel( Source ).Parent );
  2208.   { Obtain source directory either as Dir or filepath }
  2209.   if (( FileGetAttr( TFileIconPanel( Source ).FTheName )
  2210.    and faDirectory ) = faDirectory ) then
  2211.   begin  { Directory; take whole path }
  2212.     SourceDirectory := TFileIconPanel( Source ).FTheName;
  2213.   end
  2214.   else
  2215.   begin { File; get pathname }
  2216.     SourceDirectory := ExtractFilePath( TFileIconPanel( Source ).FTheName );
  2217.   end;
  2218.   Sourcedirectory := TheFIPSB.TheFWB.ForceTrailingBackSlash( SourceDirectory );
  2219.   if Pos( 'DRIVE' , FTheName ) > 0 then
  2220.   begin { Drop onto a drive icon; perform action to its default dir }
  2221.     { Pull out the letter from name }
  2222.     TheDrive := Copy( FtheName , 7 , 1 );
  2223.     { Convert it to a number }
  2224.     WhichDrive := ( Ord( TheDrive[ 1 ] ) - Ord( 'A' )) + 1;
  2225.     { Determine the target directory and drive }
  2226.     GetDir( WhichDrive , TargetDirectory );
  2227.     TargetDirectory := TheFIPSB.TheFWB.ForceTrailingbackSlash( TargetDirectory );
  2228.     { Check for shift to operate on all selections }
  2229.     if TheIOManager.WasSHIFTPressed then
  2230.     begin { Operate on all selections }
  2231.       { Obtain the parent directory of the FIP dragged over }
  2232.       SourceDirectory := ExtractFilePath( TFileIconPanel( Source ).FTheName );
  2233.       SourceDirectory := TheFIPSB.TheFWB.ForceTrailingBackslash( SourceDirectory );
  2234.       { If SourceDir subset of TargetDir then abort; recursive failure }
  2235.       if Pos( SourceDirectory , TargetDirectory ) > 0 then
  2236.       begin
  2237.         MessageDlg( 'Cannot drag to same directory!',mtError,[mbOK],0 );
  2238.         exit;
  2239.       end;
  2240.       if TargetDirectory[ 1 ] <> SourceDirectory[ 1 ] then
  2241.       begin { Copy to different drives }
  2242.         if TheIOManager.WasALTPressed then
  2243.         begin { ALT overrides and does move }
  2244.           { Set up to get all current selections }
  2245.           ThePosition := 1;
  2246.           finished := false;
  2247.           while not finished do
  2248.           begin
  2249.             CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2250.                    ThePosition );
  2251.             { If returns blank string then out of selections }
  2252.             if CurrentName = '' then finished := true else
  2253.             begin
  2254.               { If a directory signal error }
  2255.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2256.               begin
  2257.                 if MessageDlg( 'Move Directory ' + CurrentName + ' to ' +
  2258.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2259.                   TheFIPSB.TheFWB.RecursivelyMoveDirectory( CurrentName ,
  2260.                    TargetDirectory );
  2261.               end
  2262.               else
  2263.               begin
  2264.                 TheFIPSB.TheFWB.MoveTheFile( CurrentName , TargetDirectory );
  2265.               end;
  2266.             end;
  2267.             { Reset to normal cursor }
  2268.             Screen.Cursor := crDefault;
  2269.           end;
  2270.         end
  2271.         else
  2272.         begin { Default is to do copy like file manager }
  2273.           { Set up to get all current selections }
  2274.           ThePosition := 1;
  2275.           finished := false;
  2276.           while not finished do
  2277.           begin
  2278.              CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2279.                    ThePosition );
  2280.             { If returns blank string then out of selections }
  2281.             if CurrentName = '' then finished := true else
  2282.             begin
  2283.               { If a directory signal error }
  2284.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2285.               begin
  2286.                 if MessageDlg( 'Copy Directory ' + CurrentName + ' to ' +
  2287.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2288.                   TheFIPSB.TheFWB.RecursivelyCopyDirectory( CurrentName ,
  2289.                    TargetDirectory );
  2290.               end
  2291.               else
  2292.               begin
  2293.                 TheFIPSB.TheFWB.CopyTheFile( CurrentName , TargetDirectory );
  2294.               end;
  2295.             end;
  2296.             { Reset to normal cursor }
  2297.             Screen.Cursor := crDefault;
  2298.           end;
  2299.         end;
  2300.       end
  2301.       else
  2302.       begin { Copy to same drive }
  2303.         if TheIOManager.WasCTRLPressed then
  2304.         begin { CTRL overrides and does copy }
  2305.           { Set up to get all current selections }
  2306.           ThePosition := 1;
  2307.           finished := false;
  2308.           while not finished do
  2309.           begin
  2310.             CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2311.                    ThePosition );
  2312.             { If returns blank string then out of selections }
  2313.             if CurrentName = '' then finished := true else
  2314.             begin
  2315.               { If a directory signal error }
  2316.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2317.               begin
  2318.                 if MessageDlg( 'Copy Directory ' + CurrentName + ' to ' +
  2319.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2320.                   TheFIPSB.TheFWB.RecursivelyCopyDirectory( CurrentName ,
  2321.                    TargetDirectory );
  2322.               end
  2323.               else
  2324.               begin
  2325.                 TheFIPSB.TheFWB.CopyTheFile( CurrentName , TargetDirectory );
  2326.               end;
  2327.             end;
  2328.             { Reset to normal cursor }
  2329.             Screen.Cursor := crDefault;
  2330.           end;
  2331.         end
  2332.         else
  2333.         begin { Default is to do move like file manager }
  2334.           { Set up to get all current selections }
  2335.           ThePosition := 1;
  2336.           finished := false;
  2337.           while not finished do
  2338.           begin
  2339.             CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2340.                    ThePosition );
  2341.             { If returns blank string then out of selections }
  2342.             if CurrentName = '' then finished := true else
  2343.             begin
  2344.               { If a directory signal error }
  2345.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2346.               begin
  2347.                 if MessageDlg( 'Move Directory ' + CurrentName + ' to ' +
  2348.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2349.                   TheFIPSB.TheFWB.RecursivelyMoveDirectory( CurrentName ,
  2350.                    TargetDirectory );
  2351.               end
  2352.               else
  2353.               begin
  2354.                 TheFIPSB.TheFWB.MoveTheFile( CurrentName , TargetDirectory );
  2355.               end;
  2356.             end;
  2357.             { Reset to normal cursor }
  2358.             Screen.Cursor := crDefault;
  2359.           end;
  2360.         end;
  2361.       end;
  2362.     end
  2363.     else
  2364.     begin { Operate on only source }
  2365.       if TargetDirectory[ 1 ] <> SourceDirectory[ 1 ] then
  2366.       begin { Copy to different drives }
  2367.         if TheIOManager.WasALTPressed then
  2368.         begin { ALT overrides and does move }
  2369.           with Source as TFileIconPanel do
  2370.           begin
  2371.             if MessageDlg( 'Move ' + FTheName + ' to ' +
  2372.              TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2373.               TheFIPSB.TheFWB.MoveTheFile( FTheName , TargetDirectory );
  2374.           end;
  2375.         end
  2376.         else
  2377.         begin { Default is to do copy like file manager }
  2378.           with Source as TFileIconPanel do
  2379.           begin
  2380.             if MessageDlg( 'Copy ' + FTheName + ' to ' +
  2381.              TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2382.               TheFIPSB.TheFWB.CopyTheFile( FtheName , TargetDirectory );
  2383.           end;
  2384.         end;
  2385.       end
  2386.       else
  2387.       begin { Copy to same drive }
  2388.         if TheIOManager.WasCTRLPressed then
  2389.         begin { CTRL overrides and does copy }
  2390.           with Source as TFileIconPanel do
  2391.           begin
  2392.             if MessageDlg( 'Copy ' + FTheName + ' to ' +
  2393.              TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2394.               TheFIPSB.TheFWB.CopyTheFile( FTheName , TargetDirectory );
  2395.           end;
  2396.         end
  2397.         else
  2398.         begin { Default is to do move like file manager }
  2399.           with Source as TFileIconPanel do
  2400.           begin
  2401.             if MessageDlg( 'Move ' + FTheName + ' to ' +
  2402.              TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2403.              TheFIPSB.TheFWB.MoveTheFile( FtheName , TargetDirectory );
  2404.           end;
  2405.         end;
  2406.       end;
  2407.     end;
  2408.   end
  2409.   else
  2410.   begin { Drop onto dir or file icon }
  2411.     if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
  2412.     begin { Drop onto a directory; use its path as target }
  2413.       TargetDirectory := FTheName;
  2414.     end
  2415.     else
  2416.     begin { Drop onto a file; use its parent as target }
  2417.       TargetDirectory := ExtractFilePath( FTheName );
  2418.     end;
  2419.     Targetdirectory := TheFIPSB.TheFWB.ForceTrailingbackslash( TargetDirectory );
  2420.     { Check for shift to operate on all selections }
  2421.     if TheIOManager.WasSHIFTPressed then
  2422.     begin { Operate on all selections }
  2423.       { Obtain the parent directory of the FIP dragged over }
  2424.       SourceDirectory := ExtractFilePath( TFileIconPanel( Source ).FTheName );
  2425.       SourceDirectory := TheFIPSB.TheFWB.ForceTrailingBackslash( SourceDirectory );
  2426.       { If SourceDir subset of TargetDir then abort; recursive failure }
  2427.       if Pos( SourceDirectory , TargetDirectory ) > 0 then
  2428.       begin
  2429.         MessageDlg( 'Cannot drag to same directory!',mtError,[mbOK],0 );
  2430.         exit;
  2431.       end;
  2432.       if TargetDirectory[ 1 ] <> SourceDirectory[ 1 ] then
  2433.       begin { Copy to different drives }
  2434.         if TheIOManager.WasALTPressed then
  2435.         begin { ALT overrides and does move }
  2436.           { Set up to get all current selections }
  2437.           ThePosition := 1;
  2438.           finished := false;
  2439.           while not finished do
  2440.           begin
  2441.              CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2442.                    ThePosition );
  2443.             { If returns blank string then out of selections }
  2444.             if CurrentName = '' then finished := true else
  2445.             begin
  2446.               { If a directory signal error }
  2447.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2448.               begin
  2449.                 if MessageDlg( 'Move Directory ' + CurrentName + ' to ' +
  2450.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2451.                   TheFIPSB.TheFWB.RecursivelyMoveDirectory( CurrentName ,
  2452.                    TargetDirectory );
  2453.               end
  2454.               else
  2455.               begin
  2456.                 TheFIPSB.TheFWB.MoveTheFile( CurrentName , TargetDirectory );
  2457.               end;
  2458.             end;
  2459.             { Reset to normal cursor }
  2460.             Screen.Cursor := crDefault;
  2461.           end;
  2462.         end
  2463.         else
  2464.         begin { Default is to do copy like file manager }
  2465.           { Set up to get all current selections }
  2466.           ThePosition := 1;
  2467.           finished := false;
  2468.           while not finished do
  2469.           begin
  2470.             CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2471.                    ThePosition );
  2472.             { If returns blank string then out of selections }
  2473.             if CurrentName = '' then finished := true else
  2474.             begin
  2475.               { If a directory signal error }
  2476.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2477.               begin
  2478.                 if MessageDlg( 'Copy Directory ' + CurrentName + ' to ' +
  2479.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2480.                   TheFIPSB.TheFWB.RecursivelyCopyDirectory( CurrentName ,
  2481.                    TargetDirectory );
  2482.               end
  2483.               else
  2484.               begin
  2485.                 TheFIPSB.TheFWB.CopyTheFile( CurrentName , TargetDirectory );
  2486.               end;
  2487.             end;
  2488.             { Reset to normal cursor }
  2489.             Screen.Cursor := crDefault;
  2490.           end;
  2491.         end;
  2492.       end
  2493.       else
  2494.       begin { Copy to same drive }
  2495.         if TheIOManager.WasCTRLPressed then
  2496.         begin { CTRL overrides and does copy }
  2497.           { Set up to get all current selections }
  2498.           ThePosition := 1;
  2499.           finished := false;
  2500.           while not finished do
  2501.           begin
  2502.             { Call generic file getting routine based on current view}
  2503.              CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2504.                    ThePosition );
  2505.             { If returns blank string then out of selections }
  2506.             if CurrentName = '' then finished := true else
  2507.             begin
  2508.               { If a directory signal error }
  2509.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2510.               begin
  2511.                 if MessageDlg( 'Copy Directory ' + CurrentName + ' to ' +
  2512.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2513.                   TheFIPSB.TheFWB.RecursivelyCopyDirectory( CurrentName ,
  2514.                    TargetDirectory );
  2515.               end
  2516.               else
  2517.               begin
  2518.                 TheFIPSB.TheFWB.CopyTheFile( CurrentName , TargetDirectory );
  2519.               end;
  2520.             end;
  2521.             { Reset to normal cursor }
  2522.             Screen.Cursor := crDefault;
  2523.           end;
  2524.         end
  2525.         else
  2526.         begin { Default is to do move like file manager }
  2527.           { Set up to get all current selections }
  2528.           ThePosition := 1;
  2529.           finished := false;
  2530.           while not finished do
  2531.           begin
  2532.             { Call generic file getting routine based on current view}
  2533.               CurrentName := TheFIPSB.GetNextSelection( SourceDirectory ,
  2534.                    ThePosition );
  2535.             { If returns blank string then out of selections }
  2536.             if CurrentName = '' then finished := true else
  2537.             begin
  2538.               { If a directory signal error }
  2539.               if (( FileGetAttr( CurrentName ) and faDirectory ) = faDirectory ) then
  2540.               begin
  2541.                 if MessageDlg( 'Move Directory ' + CurrentName + ' to ' +
  2542.                  TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2543.                   TheFIPSB.TheFWB.RecursivelyMoveDirectory( CurrentName ,
  2544.                    TargetDirectory );
  2545.               end
  2546.               else
  2547.               begin
  2548.                 TheFIPSB.TheFWB.MoveTheFile( CurrentName , TargetDirectory );
  2549.               end;
  2550.             end;
  2551.             { Reset to normal cursor }
  2552.             Screen.Cursor := crDefault;
  2553.           end;
  2554.         end;
  2555.       end;
  2556.     end
  2557.     else
  2558.     begin { Operate on only source }
  2559.       if TargetDirectory[ 1 ] <> SourceDirectory[ 1 ] then
  2560.       begin { Copy to different drives }
  2561.         if TheIOManager.WasALTPressed then
  2562.         begin { ALT overrides and does move }
  2563.           with Source as TFileIconPanel do
  2564.           begin
  2565.             if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
  2566.             begin
  2567.               if MessageDlg( 'Move Directory ' + FTheName + ' to ' +
  2568.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2569.                 TheFIPSB.TheFWB.RecursivelyMoveDirectory( FtheName ,
  2570.                  TargetDirectory );
  2571.             end
  2572.             else
  2573.             begin
  2574.               if MessageDlg( 'Move ' + FTheName + ' to ' +
  2575.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2576.                 TheFIPSB.TheFWB.MoveTheFile( FTheName , TargetDirectory );
  2577.             end;
  2578.           end;
  2579.         end
  2580.         else
  2581.         begin { Default is to do copy like file manager }
  2582.           with Source as TFileIconPanel do
  2583.           begin
  2584.             if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
  2585.             begin
  2586.               if MessageDlg( 'Copy Directory ' + FtheName + ' to ' +
  2587.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2588.                 TheFIPSB.TheFWB.RecursivelyCopyDirectory( FtheName ,
  2589.                  TargetDirectory );
  2590.             end
  2591.             else
  2592.             begin
  2593.               if MessageDlg( 'Copy ' + FTheName + ' to ' +
  2594.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2595.                 TheFIPSB.TheFWB.CopyTheFile( FTheName , TargetDirectory );
  2596.             end;
  2597.           end;
  2598.         end;
  2599.       end
  2600.       else
  2601.       begin { Copy to same drive }
  2602.         if TheIOManager.WasCTRLPressed then
  2603.         begin { CTRL overrides and does copy }
  2604.           with Source as TFileIconPanel do
  2605.           begin
  2606.             if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
  2607.             begin
  2608.               if MessageDlg( 'Copy Directory ' + FtheName + ' to ' +
  2609.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2610.                 TheFIPSB.TheFWB.RecursivelyCopyDirectory( FtheName ,
  2611.                  TargetDirectory );
  2612.             end
  2613.             else
  2614.             begin
  2615.               if MessageDlg( 'Copy ' + FTheName + ' to ' +
  2616.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2617.                 TheFIPSB.TheFWB.CopyTheFile( FTheName , TargetDirectory );
  2618.             end;
  2619.           end;
  2620.         end
  2621.         else
  2622.         begin { Default is to do move like file manager }
  2623.           with Source as TFileIconPanel do
  2624.           begin
  2625.             if (( FileGetAttr( FTheName ) and faDirectory ) = faDirectory ) then
  2626.             begin
  2627.               if MessageDlg( 'Move Directory ' + FtheName + ' to ' +
  2628.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2629.                 TheFIPSB.TheFWB.RecursivelyMoveDirectory( FtheName ,
  2630.                  TargetDirectory );
  2631.             end
  2632.             else
  2633.             begin
  2634.               if MessageDlg( 'Move ' + FTheName + ' to ' +
  2635.                TargetDirectory + '?' , mtConfirmation , mbYesNoCancel , 0 ) = mrYes then
  2636.                 TheFIPSB.TheFWB.MoveTheFile( FTheName , TargetDirectory );
  2637.             end;
  2638.           end;
  2639.         end;
  2640.       end;
  2641.     end;
  2642.   end;
  2643.   { Call special method due to SendMessage problem! }
  2644.   TFileIconPanelScrollBox( TFileIconPanel( Source ).Parent ).Update;
  2645.   TFileIconPanelScrollBox( Parent ).Update;
  2646. end;
  2647.  
  2648. { Paint method for FIP; overrides normal paint }
  2649. procedure TFileIconPanel.Paint;
  2650. var
  2651.   TheOtherRect   : TRect;   { Holds clientrect   }
  2652.   TopColor     ,            { Holds bright color }
  2653.   BottomColor    : TColor;  { Holds dark color   }
  2654.  
  2655. { These methods are from Borland Intl., copyright 1995 }
  2656. procedure Frame3D(    Canvas       : TCanvas;
  2657.                   var TheRect      : TRect;
  2658.                       TopColor   ,
  2659.                       BottomColor  : TColor;
  2660.                       Width        : Integer );
  2661.  
  2662. procedure DoRect;
  2663. var
  2664.   TopRight, BottomLeft: TPoint;
  2665. begin
  2666.   with Canvas, TheRect do
  2667.   begin
  2668.     TopRight.X := Right;
  2669.     TopRight.Y := Top;
  2670.     BottomLeft.X := Left;
  2671.     BottomLeft.Y := Bottom;
  2672.     Pen.Color := TopColor;
  2673.     PolyLine([BottomLeft, TopLeft, TopRight]);
  2674.     Pen.Color := BottomColor;
  2675.     Dec(BottomLeft.X);
  2676.     PolyLine([TopRight, BottomRight, BottomLeft]);
  2677.   end;
  2678. end;
  2679.  
  2680. begin
  2681.   Canvas.Pen.Width := 1;
  2682.   Dec(TheRect.Bottom); Dec(TheRect.Right);
  2683.   while Width > 0 do
  2684.   begin
  2685.     Dec(Width);
  2686.     DoRect;
  2687.     InflateRect(TheRect, -1, -1);
  2688.   end;
  2689.   Inc(TheRect.Bottom); Inc(TheRect.Right);
  2690. end;
  2691.  
  2692. procedure AdjustColors(Bevel: TPanelBevel);
  2693. begin
  2694.   TopColor := FHighlightColor;
  2695.   if Bevel = bvLowered then TopColor := FShadowColor;
  2696.   BottomColor := FShadowColor;
  2697.   if Bevel = bvLowered then BottomColor := FHighlightColor;
  2698. end;
  2699.  
  2700. { Custom code begins here }
  2701. begin
  2702.   { Get the rectangle of the control with API/method call }
  2703.   TheOtherRect := GetClientRect;
  2704.   { draw basic rectangle with basic color }
  2705.   with Canvas do
  2706.   begin
  2707.     Brush.Color := Color;
  2708.     FillRect(TheOtherRect);
  2709.   end;
  2710.   { Set up for top "icon" frame  and draw it with frame3d }
  2711.   TheOtherRect.Right := Width;
  2712.   TheOtherRect.Bottom := Round( Height * 0.75 ) - 6 ;
  2713.   if BevelOuter <> bvNone then
  2714.   begin
  2715.     AdjustColors(BevelOuter);
  2716.     Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  2717.   end;
  2718.   Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  2719.   if BevelInner <> bvNone then
  2720.   begin
  2721.     AdjustColors(BevelInner);
  2722.     Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  2723.   end;
  2724.   { Do the same for the lower "label" frame }
  2725.   TheOtherRect.Top := Round( Height * 0.75 ) - 5;
  2726.   TheOtherRect.Left := 0;
  2727.   TheOtherRect.Bottom := Height;
  2728.   TheOtherRect.Right := Width;
  2729.   if BevelOuter <> bvNone then
  2730.   begin
  2731.     AdjustColors(BevelOuter);
  2732.     Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  2733.   end;
  2734.   Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  2735.   if BevelInner <> bvNone then
  2736.   begin
  2737.     AdjustColors(BevelInner);
  2738.     Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  2739.   end;
  2740.   { Then draw the icon using canvas draw method }
  2741.   Canvas.Draw( (( Width - 32 ) div 2 ) + 1 ,
  2742.   ((( Round( Height * 0.75 ) - 6 ) - 32 ) div 2 ) + 1 , FTheIcon );
  2743. end;
  2744.  
  2745. { This procedure clears a scrollbox of all FileIconPanels }
  2746. procedure TFileIconPanelScrollbox.ClearTheFIPs;
  2747. var Counter_1 : Integer;
  2748.     TheComponent : TComponent;
  2749. begin
  2750.   { Note that must use while loop since component count continually }
  2751.   { decreases as removes are made!                                  }
  2752.   while ComponentCount > 0 do
  2753.   begin
  2754.     { Save the component as a generic TComponent }
  2755.     TheComponent := Components[ 0 ];
  2756.     { Call removecomponent to pull it out of the owner list for sb }
  2757.     { This avoids GPF when freeing the sb.                         }
  2758.     RemoveComponent( Components[ 0 ]);
  2759.     if ControlCount > 0 then
  2760.      RemoveControl( Controls[ 0 ] );
  2761.     { Typecast the pointer and free it to release memory and res. }
  2762.     TheParentForm.InsertComponent( TheComponent );
  2763.   end;
  2764. end;
  2765.  
  2766. { This procedure scans for drives and obtains their type and creates file }
  2767. { icon panels to represent them.                                          }
  2768. procedure TFileIconPanelScrollBox.AddDriveIcons( var XCounter ,
  2769.            YCounter : Integer );
  2770. type
  2771.   { This if from filectrl unit; reproduce here for completeness }
  2772.   TDriveType = (dtUnknown, dtNoDrive, dtFloppy, dtFixed, dtNetwork, dtCDROM,
  2773.                 dtRAM);
  2774. var
  2775.   DrivePC         : array[0..256] of char;
  2776.   DriveNum        : Integer;         { Used to get next drive via DOS fn   }
  2777.   IconType        : Integer;         { Used to hold icon type (defacto dt) }
  2778.   DriveChar       : Char;            { Used to hold drive letter           }
  2779.   DriveType       : TDriveType;      { Used for set-valued drive type      }
  2780.   Finished        : Boolean;         { Loop flag                           }
  2781.   TheFIP          : TFileIconPanel;  { Generic FileIconPanel variable      }
  2782.   ButtonColor   ,                    { Main panel color                    }
  2783.   ButtonHLColor ,                    { Bright panel color                  }
  2784.   ButtonSColor  ,                    { Dark panel color                    }
  2785.   Textcolor       : TColor;          { Label text color                    }
  2786.  
  2787. (*{ This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
  2788. { Check whether drive is a CD-ROM.  Returns True if MSCDEX is installed }
  2789. {  and the drive is using a CD driver                                   }
  2790.  
  2791. function IsCDROM(DriveNum: Integer): Boolean; assembler;
  2792. asm
  2793.   MOV   AX,1500h { look for MSCDEX }
  2794.   XOR   BX,BX
  2795.   INT   2fh
  2796.   OR    BX,BX
  2797.   JZ    @Finish
  2798.   MOV   AX,150Bh { check for using CD driver }
  2799.   MOV   CX,DriveNum
  2800.   INT   2fh
  2801.   OR    AX,AX
  2802.   @Finish:
  2803. end;
  2804.  
  2805. { This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
  2806. { Check whether drive is a RAM drive.                                   }
  2807. function IsRAMDrive(DriveNum: Integer): Boolean; assembler;
  2808. var
  2809.   TempResult: Boolean;
  2810. asm
  2811.   MOV   TempResult,False
  2812.   PUSH  DS
  2813.   MOV   BX,SS
  2814.   MOV   DS,BX
  2815.   SUB   SP,0200h
  2816.   MOV   BX,SP
  2817.   MOV   AX,DriveNum
  2818.   MOV   CX,1
  2819.   XOR   DX,DX
  2820.   INT   25h  { read boot sector }
  2821.   ADD   SP,2
  2822.   JC    @ItsNot
  2823.   MOV   BX,SP
  2824.   CMP   BYTE PTR SS:[BX+15h],0F8h  { reverify fixed disk }
  2825.   JNE   @ItsNot
  2826.   CMP   BYTE PTR SS:[BX+10h],1  { check for single FAT }
  2827.   JNE   @ItsNot
  2828.   MOV   TempResult,True
  2829.   @ItsNot:
  2830.   ADD   SP,0200h
  2831.   POP   DS
  2832.   MOV   AL, TempResult
  2833. end;
  2834.  
  2835. { This code is from the FileCtrl Unit; copyright Borland Intl 1995      }
  2836. { Finds the type of a drive letter.                                     }
  2837. function FindDriveType(DriveNum: Integer): TDriveType;
  2838. begin
  2839.   Result := TDriveType(GetDriveType(DriveNum));
  2840.   if (Result = dtFixed) or (Result = dtNetwork) then
  2841.   begin
  2842.     if IsCDROM(DriveNum) then Result := dtCDROM
  2843.     else if (Result = dtFixed) then
  2844.     begin
  2845.         { do not check for RAMDrive under Windows NT }
  2846.       if ((GetWinFlags and $4000) = 0) and IsRAMDrive(DriveNum) then
  2847.         Result := dtRAM;
  2848.     end;
  2849.   end;
  2850. end;*)
  2851.  
  2852. begin
  2853.   { Set the button colors to an aquamarine color scheme for drives }
  2854.   ButtonColor := clTeal;
  2855.   ButtonHLColor := clAqua;
  2856.   ButtonSColor := clNavy;
  2857.   TextColor := clblack;
  2858.   { Set initial variables before looping for all drives }
  2859.   finished := false;
  2860.   DriveNum := 0;
  2861.   while not finished do
  2862.   begin
  2863.     { Start with no drive found }
  2864.     IconType := 0;
  2865.     (*=============REMOVED DUE TO WINDOWS 95=========
  2866.     { Call the Borland method to get the drive info }
  2867.     DriveType := FindDriveType(DriveNum);
  2868.     ===============END WINDOWS 95 REMOVAL==========*)
  2869.     { Set its letter and make it uppercase }
  2870.     DriveChar := Chr(DriveNum + ord('a'));
  2871.     DriveChar := Upcase(DriveChar);
  2872.     StrPCopy( DrivePC , DriveChar + ':\' );
  2873.     {*&&&&&&&&&&&&&&&  WIN 95 CALL  &&&&&&&&&&&&&&&&&&&*}
  2874.     DriveType := TDriveType(GetDriveType( DrivePC ));
  2875.     { Assign an icon based on the drive type; if no drive exists type is nil }
  2876.     case DriveType of
  2877.       dtFloppy  : IconType := 1;
  2878.       dtFixed   : IconType := 2;
  2879.       dtNetwork : IconType := 3;
  2880.       dtCDROM   : IconType := 4;
  2881.       dtRAM     : IconType := 5;
  2882.     end;
  2883.     { Set to check next drive letter }
  2884.     DriveNum := DriveNum + 1;
  2885.     { But if no match then out of drives so set exit flag }
  2886.     if IconType = 0 then finished := true;
  2887.     { If drive was valid then set up the New FileIconPanel on the imported }
  2888.     { Scrollbox                                                            }
  2889.     if not finished then
  2890.     begin
  2891.       { Create the FileIconPanel and set its parent for memory mgmt and display}
  2892.       TheFIP := TFileIconPanel.Create( Self );
  2893.       TheFIP.Parent := Self;
  2894.       { Call its initialize method with imported position values and the   }
  2895.       { preset color scheme, a drive caption, and a minimum font. Note the }
  2896.       { setting of the ExtraData field to non-zero; this signals a drive   }
  2897.       { rather than a file being sent in.                                  }
  2898.       TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
  2899.        (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
  2900.         7 , ButtonColor, ButtonHLColor,
  2901.        ButtonSColor , TextColor , 'DRIVE ' + DriveChar + ':' , 'MS Serif' , [] ,
  2902.        IconType );
  2903.       { Increment the column counter; if it exceeds max move to New row      }
  2904.       { Note that these are 'var' parameters and will export final position. }
  2905.       XCounter := XCounter + 1;
  2906.       if XCounter > MaxIconsInARow then
  2907.       begin
  2908.         XCounter := 1;
  2909.         YCounter := YCounter + 1;
  2910.       end;
  2911.     end;
  2912.   end;
  2913. end;
  2914.  
  2915. { This procedure assigns colors to FIP's based on file attributes }
  2916. procedure TFileIconPanelScrollBox.GetColorsForFileIcon( TheFile : String;
  2917.            var BC , HC , SC , TC : TColor );
  2918. var AmADir      ,             { Booleans hold file attribs }
  2919.     AmAnArchive ,
  2920.     AmAVolumeId ,
  2921.     AmHidden    ,
  2922.     AmReadOnly  ,
  2923.     AmSystem      : Boolean;
  2924. begin
  2925.   { Make the call to internal fileworkbench to set attributes }
  2926.   TheFWB.GetFileAttributes( TheFile , AmADir , AmAnArchive , AmAVolumeId ,
  2927.    AmHidden , AmReadOnly , AmSystem );
  2928.   { Volume ID has no subtypes }
  2929.   if AmAVolumeID then
  2930.   begin
  2931.     BC := clOlive;
  2932.     HC := clYellow;
  2933.     SC := clBlack;
  2934.     TC := clWhite;
  2935.     exit;
  2936.   end;
  2937.   { Check all directory combinations }
  2938.   if AmADir then
  2939.   begin
  2940.     BC := clNavy;
  2941.     HC := clBlue;
  2942.     SC := clBlack;
  2943.     TC := clWhite;
  2944.     if AmHidden then
  2945.     begin
  2946.       if AmReadOnly then
  2947.       begin
  2948.         if AmSystem then
  2949.         begin { One HECK of a file! }
  2950.           BC := clBlack;
  2951.           HC := clSilver;
  2952.           SC := clGray;
  2953.           TC := clWhite;
  2954.         end
  2955.         else
  2956.         begin { Dir,RO,Hid }
  2957.           BC := clMaroon;
  2958.           HC := clFuchsia;
  2959.           SC := clGreen;
  2960.           TC := clWhite;
  2961.         end;
  2962.       end
  2963.       else
  2964.       begin { Dir,Hid }
  2965.         BC := clPurple;
  2966.         HC := clFuchsia;
  2967.         SC := clBlack;
  2968.         TC := clWhite;
  2969.       end;
  2970.     end
  2971.     else
  2972.     begin
  2973.       if AmReadOnly then
  2974.       begin
  2975.         if AmSystem then
  2976.         begin { Dir,RO,Sys }
  2977.           BC := clMaroon;
  2978.           HC := clLime;
  2979.           SC := clGreen;
  2980.           TC := clWhite;
  2981.         end
  2982.         else
  2983.         begin { Dir,RO }
  2984.           BC := clGreen;
  2985.           HC := clLime;
  2986.           SC := clBlack;
  2987.           TC := clWhite;
  2988.         end;
  2989.       end
  2990.       else
  2991.       begin
  2992.         if AmSystem then
  2993.         begin { Dir,Sys }
  2994.           BC := clMaroon;
  2995.           HC := clRed;
  2996.           SC := clBlack;
  2997.           TC := clWhite;
  2998.         end;
  2999.       end;
  3000.     end;
  3001.   end
  3002.   else { Archive Only; check all combinations }
  3003.   begin
  3004.     BC := clSilver;
  3005.     HC := clWhite;
  3006.     SC := clGray;
  3007.     TC := clBlack;
  3008.     if AmHidden then
  3009.     begin
  3010.       if AmReadOnly then
  3011.       begin
  3012.         if AmSystem then
  3013.         begin { Hid,RO,Sys }
  3014.           BC := clRed;
  3015.           HC := clLime;
  3016.           SC := clPurple;
  3017.           TC := clBlack;
  3018.         end
  3019.         else
  3020.         begin { RO,Hid }
  3021.           BC := clLime;
  3022.           HC := clFuchsia;
  3023.           SC := clMaroon;
  3024.           TC := clBlack;
  3025.         end;
  3026.       end
  3027.       else
  3028.       begin { Hid }
  3029.         BC := clFuchsia;
  3030.         HC := clWhite;
  3031.         SC := clPurple;
  3032.         TC := clBlack;
  3033.       end;
  3034.     end
  3035.     else
  3036.     begin
  3037.       if AmReadOnly then
  3038.       begin
  3039.         if AmSystem then
  3040.         begin { RO,Sys }
  3041.           BC := clRed;
  3042.           HC := clLime;
  3043.           SC := clMaroon;
  3044.           TC := clBlack;
  3045.         end
  3046.         else
  3047.         begin { RO }
  3048.           BC := clLime;
  3049.           HC := clWhite;
  3050.           SC := clGreen;
  3051.           TC := clBlack;
  3052.         end;
  3053.       end
  3054.       else
  3055.       begin
  3056.         if AmSystem then
  3057.         begin { System }
  3058.           BC := clRed;
  3059.           HC := clWhite;
  3060.           SC := clMaroon;
  3061.           TC := clBlack;
  3062.         end;
  3063.       end;
  3064.     end;
  3065.   end;
  3066. end;
  3067.  
  3068. { This procedure gets all icons for an given directory, including drives and }
  3069. { standard subdirectories. It does not get special combinations or h/ro/sys  }
  3070. procedure TFileIconPanelScrollbox.GetIconsForEntireDirectory(
  3071.             TargetPath  : String );
  3072. var Finished        : Boolean;         { Loop flag              }
  3073.     TheSR           : TSearchRec;      { Searchrecord for FF/FN }
  3074.     TheResult       : Integer;         { return variable        }
  3075.     TempPath        : String;          { path for FF/FN         }
  3076.     TheFIP          : TFileIconPanel;  { generic FIP holder     }
  3077.     RowCounter    ,                    { position in row of FIP }
  3078.     ColumnCounter   : Integer;         { position in col of FIP }
  3079.     ButtonColor   ,                    { main panel color       }
  3080.     ButtonHLColor ,                    { bright panel color     }
  3081.     ButtonSColor  ,                    { dark panel color       }
  3082.     Textcolor       : TColor;          { label text color       }
  3083.     IsADir ,                           { Variable for file attr }
  3084.     IsAnArchive ,
  3085.     IsAVolumeID,
  3086.     IsAReadOnlyFile,
  3087.     IsAHiddenFile ,
  3088.     IsASystemFile     : Boolean;
  3089.     MaxTextLength     : Integer;       { Used to safely set size}
  3090. begin
  3091.   { hide during refresh }
  3092.   Visible := false;
  3093.   { Get the icon sizes }
  3094.   TheFIP := TFileIconPanel.Create( Self );
  3095.   TheFIP.Parent := Self;
  3096.   TheFIP.FTheLabel.Canvas.Font.Name := 'MS Serif';
  3097.   TheFIP.FTheLabel.Canvas.Font.Size := 7;
  3098.   MaxTextLength := TheFIP.FTheLabel.Canvas.TextWidth( 'COMMAND.COM' );
  3099.   TheFIP.Free;
  3100.   TheIconSize := MaxTextLength + 13;
  3101.   TheIconSpacing := TheIconSize + 5;
  3102.   { Set up maximum icons per row based on screen size }
  3103.   MaxIconsInARow := ( Screen.Width div TheIconSpacing );
  3104.   { Set up the position counters }
  3105.   RowCounter := 1;
  3106.   ColumnCounter := 1;
  3107.   { Get the drives for the current machine }
  3108.   AddDriveIcons( ColumnCounter , RowCounter  );
  3109.   { Set up the initial variables }
  3110.   Finished := false;
  3111.   TempPath := TargetPath + '*.*';
  3112.   { Make the call to FindFirst set to get any file; will return '.' }
  3113.   { so discard it.                                                  }
  3114.   TheResult := FindFirst( TempPath , faAnyFile , TheSR );
  3115.   { loop through all files in the directory and look for directories }
  3116.   while not Finished do
  3117.   begin
  3118.     { Make call to FindNext, using only SearchRecord from FindFirst }
  3119.     TheResult := FindNext( TheSR );
  3120.     { A -1 result means no more files so exit }
  3121.     if TheResult <> 0 then finished := true else
  3122.     begin
  3123.       { Otherwise check for a directory attribute }
  3124.       if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory ) =
  3125.        faDirectory ) then
  3126.       begin
  3127.         GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  3128.          ButtonHLColor , ButtonSColor , TextColor );
  3129.         { If found create a New FileIconPanel on the imported scrollbox }
  3130.         { Note sending 0 ExtraData parameter to indicate file not drive }
  3131.         TheFIP := TFileIconPanel.Create( Self );
  3132.         TheFIP.Parent := Self;
  3133.         TheFIP.Initialize((( ColumnCounter - 1 ) * TheIconSpacing ),
  3134.          (( RowCounter - 1  ) * TheIconSpacing ) , TheIconSize, TheIconSize ,
  3135.           3 , 7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
  3136.            TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
  3137.         { Increment column counter and move to New row if past limit }
  3138.         ColumnCounter := ColumnCounter + 1;
  3139.         if ColumnCounter > MaxIconsInARow then
  3140.         begin
  3141.           ColumnCounter := 1;
  3142.           RowCounter := RowCounter + 1;
  3143.         end;
  3144.       end;
  3145.     end;
  3146.   end;
  3147.   { Set up New initialization variables }
  3148.   Finished := false;
  3149.   TempPath := TargetPath + '*.*';
  3150.   { Make needed call to FindFirst and discard '.' }
  3151.   TheResult := FindFirst( TempPath , faAnyFile , TheSR );
  3152.   while not Finished do
  3153.   begin
  3154.     { Loop through file again, this time getting only archive files }
  3155.     TheResult := FindNext( TheSR );
  3156.     { Result of -1 indicates no more files }
  3157.     if TheResult <> 0 then Finished := true else
  3158.     begin
  3159.       { If faArchive file then add New FileIconPanel }
  3160.       TheFWB.GetFileAttributes(( Targetpath + TheSR.Name ) , IsADir ,
  3161.        IsAnArchive , IsAVolumeId , IsAHiddenFile , IsAReadOnlyFile ,
  3162.         IsASystemFile );
  3163.       if (( IsAnArchive ) and ( not IsADir )) then
  3164.       begin
  3165.         GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  3166.          ButtonHLColor , ButtonSColor , TextColor );
  3167.         { Initialize New FileIconPanel and call initialize, sending 0 ED }
  3168.         TheFIP := TFileIconPanel.Create( Self );
  3169.         TheFIP.Parent := Self;
  3170.         TheFIP.Initialize((( ColumnCounter - 1 ) * TheIconSpacing ),
  3171.          (( RowCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize ,
  3172.           3 , 7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
  3173.            TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
  3174.         { Increment column counter and if needed row counter }
  3175.         ColumnCounter := ColumnCounter + 1;
  3176.         if ColumnCounter > MaxIconsInARow then
  3177.         begin
  3178.           ColumnCounter := 1;
  3179.           RowCounter := RowCounter + 1;
  3180.         end;
  3181.       end;
  3182.     end;
  3183.   end;
  3184.   { Reset to visible }
  3185.   Visible := true;
  3186. end;
  3187.  
  3188. { Update method for FIPscrollbox }
  3189. procedure TFileIconPanelScrollBox.Update;
  3190. begin
  3191.   IconsNeedRefreshing := true;
  3192.   { Force a repaint }
  3193.   InvalidateRect( TheStoredHandle , nil , true );
  3194. end;
  3195.  
  3196. { Create method for FIPScrollbox }
  3197. constructor TFileIconPanelScrollBox.Create( AOwner : TComponent );
  3198. begin
  3199.   inherited Create( AOwner );
  3200.   TheFWB := TFileWorkBench.Create( Self );
  3201. end;
  3202.  
  3203. { This function returns the next selected file's name }
  3204. function TFileIconPanelScrollBox.GetNextSelection( SourceDirectory : String;
  3205.                            var CurrentItem : Integer ) : String;
  3206. var TheResult    : String;      { Holds result of function }
  3207.     TheComponent : TComponent;  { Used for typecast        }
  3208.     finished     : boolean;     { Loop control variable    }
  3209.     TheComponentCount : Integer;
  3210. begin
  3211.   TheComponentCount := ComponentCount;
  3212.   { If past end of components exit with no result }
  3213.   if CurrentItem > TheComponentCount then TheResult := '' else
  3214.   begin
  3215.     { Set loop counter and run till find match or run out }
  3216.     finished := false;
  3217.     while not finished do
  3218.     begin
  3219.       { Pull component out of the list and check it }
  3220.       TheComponent := Components[ CurrentItem - 1 ];
  3221.       { Increment counter for later }
  3222.       CurrentItem := CurrentItem + 1;
  3223.       { Do the typecast with AS }
  3224.       if TheComponent is TFileIconPanel then
  3225.       with TheComponent as TFileIconPanel do
  3226.       begin
  3227.         { If its selected make sure OK }
  3228.         if Selected then
  3229.         begin
  3230.           { Don't accept backup for this level of operation }
  3231.           if FTheLabel.Caption <> '..' then
  3232.           begin
  3233.             { Otherwise return the name and abort the loop }
  3234.             TheResult := FTheName;
  3235.             finished := true;
  3236.           end;
  3237.         end
  3238.         else
  3239.         begin
  3240.           { Check to see if out of components }
  3241.           if CurrentItem > TheComponentCount then
  3242.           begin
  3243.             { If so signal error and abort }
  3244.             TheResult := '';
  3245.             finished := true;
  3246.           end;
  3247.         end;
  3248.       end;
  3249.     end;
  3250.   end;
  3251.   GetNextSelection := TheResult;
  3252. end;
  3253.  
  3254. { This procedure places a selection of files in the display based on wildcards }
  3255. procedure TFileIconPanelScrollBox.DisplayRecursiveSearchResults(
  3256.            TheStartingDirectory : String );
  3257. var XCounter ,
  3258.     YCounter   : Integer;
  3259.  
  3260. { This procedure does a recursive file search by first getting all matches (in-}
  3261. { cluding directories) and adding them to the list. Then it checks for ALL the }
  3262. { subdirectories and does the same trick on them til there are no more matches }
  3263. { and no more subdirectories, at which point it exits and recurses back up.    }
  3264. procedure RecursiveFileSearch( TheWorkingDirectory : String; var XCounter ,
  3265.                                YCounter : Integer );
  3266.  
  3267. { VITAL!!! These variables MUST be local for recursrion to work! }
  3268. var
  3269.     Finished        : Boolean;         { Loop flag              }
  3270.     TheSR           : TSearchRec;      { Searchrecord for FF/FN }
  3271.     TheResult       : Integer;         { return variable        }
  3272.     TargetPath ,
  3273.     FileMask   ,
  3274.     TheStoredWorkingDirectory ,
  3275.     ModifiedDirectory  : String;       { path for FF/FN         }
  3276.     TheFIP          : TFileIconPanel;  { generic FIP holder     }
  3277.     ButtonColor   ,                    { main panel color       }
  3278.     ButtonHLColor ,                    { bright panel color     }
  3279.     ButtonSColor  ,                    { dark panel color       }
  3280.     Textcolor       : TColor;          { label text color       }
  3281.  
  3282. begin
  3283.   { Jump out if abort pressed }
  3284.   if GlobalAbortFlag then exit;
  3285.   { Set up the initial variables }
  3286.   Finished := false;
  3287.   TheStoredWorkingDirectory := TheWorkingDirectory;
  3288.   Targetpath := ExtractFilePath( TheWorkingDirectory );
  3289.   FileMask := ExtractFileName( TheWorkingDirectory );
  3290.   { Make the call to FindFirst set to get any file }
  3291.   TheResult := FindFirst( TheWorkingDirectory , faAnyFile , TheSR );
  3292.   if TheResult < 0 then finished := true;
  3293.   if (( TheSr.Name <> '.' ) and ( TheSr.Name <> '..' ) and ( TheResult >= 0 ))
  3294.   then begin
  3295.     if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory ) =
  3296.      faDirectory ) then
  3297.     begin { A directory }
  3298.       GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  3299.        ButtonHLColor , ButtonSColor , TextColor );
  3300.       { If found create a New FileIconPanel on the imported scrollbox }
  3301.       { Note sending 0 ExtraData parameter to indicate file not drive }
  3302.       TheFIP := TFileIconPanel.Create( Self );
  3303.       TheFIP.Parent := Self;
  3304.       TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
  3305.        (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
  3306.         7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor , TargetPath
  3307.          + TheSr.Name , 'MS Serif' , [] , 0 );
  3308.       { Increment column counter and move to New row if past limit }
  3309.       XCounter := XCounter + 1;
  3310.       if XCounter > MaxIconsInARow then
  3311.       begin
  3312.         XCounter := 1;
  3313.         YCounter := YCounter + 1;
  3314.       end;
  3315.     end
  3316.     else
  3317.     begin { A File }
  3318.       { Set up the default color scheme for files }
  3319.       GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  3320.        ButtonHLColor , ButtonSColor , TextColor );
  3321.       { If found create a New FileIconPanel on the imported scrollbox }
  3322.       { Note sending 0 ExtraData parameter to indicate file not drive }
  3323.       TheFIP := TFileIconPanel.Create( Self );
  3324.       TheFIP.Parent := Self;
  3325.       TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
  3326.        (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize, TheIconSize , 3 ,
  3327.         7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor , TargetPath
  3328.          + TheSr.Name , 'MS Serif' , [] , 0 );
  3329.       { Increment column counter and move to New row if past limit }
  3330.       XCounter := XCounter + 1;
  3331.       if XCounter > MaxIconsInARow then
  3332.       begin
  3333.         XCounter := 1;
  3334.         YCounter := YCounter + 1;
  3335.       end;
  3336.     end;
  3337.   end;
  3338.   { loop through all files in the directory and look for matches }
  3339.   while not Finished do
  3340.   begin
  3341.     { Allow keyboard processing and jump out if c-break hit }
  3342.     Application.ProcessMessages;
  3343.     if GlobalAbortFlag then exit;
  3344.     { Make call to FindNext, using only SearchRecord from FindFirst }
  3345.     TheResult := FindNext( TheSR );
  3346.     { A -1 result means no more files so exit }
  3347.     if TheResult <> 0 then finished := true else
  3348.     begin
  3349.       if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory ) =
  3350.        faDirectory ) then
  3351.       begin { A directory }
  3352.         { Set up the blue color scheme for directories }
  3353.         GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  3354.          ButtonHLColor , ButtonSColor , TextColor );
  3355.         { If found create a New FileIconPanel on the imported scrollbox }
  3356.         { Note sending 0 ExtraData parameter to indicate file not drive }
  3357.         TheFIP := TFileIconPanel.Create( Self );
  3358.         TheFIP.Parent := Self;
  3359.         TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
  3360.          (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
  3361.            7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
  3362.             TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
  3363.         { Increment column counter and move to New row if past limit }
  3364.         XCounter := XCounter + 1;
  3365.         if XCounter > MaxIconsInARow then
  3366.         begin
  3367.           XCounter := 1;
  3368.           YCounter := YCounter + 1;
  3369.         end;
  3370.       end
  3371.       else
  3372.       begin { A File }
  3373.         { Set up the default color scheme for files }
  3374.         GetColorsForFileIcon( TargetPath + TheSR.Name , ButtonColor ,
  3375.          ButtonHLColor , ButtonSColor , TextColor );
  3376.         { If found create a New FileIconPanel on the imported scrollbox }
  3377.         { Note sending 0 ExtraData parameter to indicate file not drive }
  3378.         TheFIP := TFileIconPanel.Create( Self );
  3379.         TheFIP.Parent := Self;
  3380.         TheFIP.Initialize((( XCounter - 1 ) * TheIconSpacing ),
  3381.          (( YCounter - 1  ) * TheIconSpacing ) , TheIconSize , TheIconSize , 3 ,
  3382.           7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor ,
  3383.            TargetPath + TheSr.Name , 'MS Serif' , [] , 0 );
  3384.         { Increment column counter and move to New row if past limit }
  3385.         XCounter := XCounter + 1;
  3386.         if XCounter > MaxIconsInARow then
  3387.         begin
  3388.           XCounter := 1;
  3389.           YCounter := YCounter + 1;
  3390.         end;
  3391.       end;
  3392.     end;
  3393.   end;
  3394.   { Set up the variables to do recursive calls on all directories}
  3395.   Finished := false;
  3396.   ModifiedDirectory := ExtractFilePath( TheWorkingdirectory ) + '*.*';
  3397.   { Make the call to FindFirst set to get any file, ignore result }
  3398.   TheResult := FindFirst( ModifiedDirectory , faDirectory , TheSR );
  3399.   while not Finished do
  3400.   begin
  3401.     { Allow keyboard input and jump out if c-break hit }
  3402.     Application.ProcessMessages;
  3403.     if GlobalAbortFlag then exit;
  3404.     { Make call to FindNext, using only SearchRecord from FindFirst }
  3405.     TheResult := FindNext( TheSR );
  3406.     { A -1 result means no more files so exit }
  3407.     if TheResult <> 0 then finished := true
  3408.     else
  3409.     begin
  3410.       if TheSR.Name <> '..' then { Ignore backup in this case }
  3411.       begin
  3412.         { Do second check due to bug in FindNext }
  3413.         if (( FileGetAttr( TargetPath + TheSR.Name ) and faDirectory )
  3414.         = faDirectory ) then
  3415.         begin
  3416.           { Set up modified directory to recurse into }
  3417.           ModifiedDirectory := ExtractFilePath( TheStoredWorkingDirectory ) +
  3418.            TheSR.Name + '\' + FileMask;
  3419.           { Perform the recursion }
  3420.           RecursiveFileSearch( ModifiedDirectory , XCounter , YCounter );
  3421.         end;
  3422.       end;
  3423.     end;
  3424.   end;
  3425. end;
  3426.  
  3427. begin
  3428.   { Keep the scrollbox from updating during refresh }
  3429.   Visible := false;
  3430.   { Make the clear call }
  3431.   ClearTheFIPs;
  3432.   XCounter := 1;
  3433.   YCounter := 1;
  3434.   { Get the drives for the current machine }
  3435.   AddDriveIcons( XCounter , YCounter );
  3436.   RecursiveFileSearch( TheStartingDirectory , XCounter , YCounter );
  3437.   { Make the scrollbox visible again }
  3438.   Visible := true;
  3439. end;
  3440.  
  3441. end.
  3442.